KTH framework for Nek5000 toolboxes; testing version  0.0.1
blas.f
Go to the documentation of this file.
1  subroutine caxpy(n,ca,cx,incx,cy,incy)
2 c
3 c constant times a vector plus a vector.
4 c jack dongarra, linpack, 3/11/78.
5 c modified 12/3/93, array(1) declarations changed to array(*)
6 c
7  complex cx(*),cy(*),ca
8  integer i,incx,incy,ix,iy,n
9 c
10  if(n.le.0)return
11  if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return
12  if(incx.eq.1.and.incy.eq.1)go to 20
13 c
14 c code for unequal increments or equal increments
15 c not equal to 1
16 c
17  ix = 1
18  iy = 1
19  if(incx.lt.0)ix = (-n+1)*incx + 1
20  if(incy.lt.0)iy = (-n+1)*incy + 1
21  do 10 i = 1,n
22  cy(iy) = cy(iy) + ca*cx(ix)
23  ix = ix + incx
24  iy = iy + incy
25  10 continue
26  return
27 c
28 c code for both increments equal to 1
29 c
30  20 do 30 i = 1,n
31  cy(i) = cy(i) + ca*cx(i)
32  30 continue
33  return
34  end
35  subroutine ccopy(n,cx,incx,cy,incy)
36 c
37 c copies a vector, x, to a vector, y.
38 c jack dongarra, linpack, 3/11/78.
39 c modified 12/3/93, array(1) declarations changed to array(*)
40 c
41  complex cx(*),cy(*)
42  integer i,incx,incy,ix,iy,n
43 c
44  if(n.le.0)return
45  if(incx.eq.1.and.incy.eq.1)go to 20
46 c
47 c code for unequal increments or equal increments
48 c not equal to 1
49 c
50  ix = 1
51  iy = 1
52  if(incx.lt.0)ix = (-n+1)*incx + 1
53  if(incy.lt.0)iy = (-n+1)*incy + 1
54  do 10 i = 1,n
55  cy(iy) = cx(ix)
56  ix = ix + incx
57  iy = iy + incy
58  10 continue
59  return
60 c
61 c code for both increments equal to 1
62 c
63  20 do 30 i = 1,n
64  cy(i) = cx(i)
65  30 continue
66  return
67  end
68  complex function cdotc(n,cx,incx,cy,incy)
69 c
70 c forms the dot product of two vectors, conjugating the first
71 c vector.
72 c jack dongarra, linpack, 3/11/78.
73 c modified 12/3/93, array(1) declarations changed to array(*)
74 c
75  complex cx(*),cy(*),ctemp
76  integer i,incx,incy,ix,iy,n
77 c
78  ctemp = (0.0,0.0)
79  cdotc = (0.0,0.0)
80  if(n.le.0)return
81  if(incx.eq.1.and.incy.eq.1)go to 20
82 c
83 c code for unequal increments or equal increments
84 c not equal to 1
85 c
86  ix = 1
87  iy = 1
88  if(incx.lt.0)ix = (-n+1)*incx + 1
89  if(incy.lt.0)iy = (-n+1)*incy + 1
90  do 10 i = 1,n
91  ctemp = ctemp + conjg(cx(ix))*cy(iy)
92  ix = ix + incx
93  iy = iy + incy
94  10 continue
95  cdotc = ctemp
96  return
97 c
98 c code for both increments equal to 1
99 c
100  20 do 30 i = 1,n
101  ctemp = ctemp + conjg(cx(i))*cy(i)
102  30 continue
103  cdotc = ctemp
104  return
105  end
106  complex function cdotu(n,cx,incx,cy,incy)
107 c
108 c forms the dot product of two vectors.
109 c jack dongarra, linpack, 3/11/78.
110 c modified 12/3/93, array(1) declarations changed to array(*)
111 c
112  complex cx(*),cy(*),ctemp
113  integer i,incx,incy,ix,iy,n
114 c
115  ctemp = (0.0,0.0)
116  cdotu = (0.0,0.0)
117  if(n.le.0)return
118  if(incx.eq.1.and.incy.eq.1)go to 20
119 c
120 c code for unequal increments or equal increments
121 c not equal to 1
122 c
123  ix = 1
124  iy = 1
125  if(incx.lt.0)ix = (-n+1)*incx + 1
126  if(incy.lt.0)iy = (-n+1)*incy + 1
127  do 10 i = 1,n
128  ctemp = ctemp + cx(ix)*cy(iy)
129  ix = ix + incx
130  iy = iy + incy
131  10 continue
132  cdotu = ctemp
133  return
134 c
135 c code for both increments equal to 1
136 c
137  20 do 30 i = 1,n
138  ctemp = ctemp + cx(i)*cy(i)
139  30 continue
140  cdotu = ctemp
141  return
142  end
143  SUBROUTINE cgbmv ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
144  $ beta, y, incy )
145 * .. Scalar Arguments ..
146  COMPLEX ALPHA, BETA
147  INTEGER INCX, INCY, KL, KU, LDA, M, N
148  CHARACTER*1 TRANS
149 * .. Array Arguments ..
150  COMPLEX A( lda, * ), X( * ), Y( * )
151 * ..
152 *
153 * Purpose
154 * =======
155 *
156 * CGBMV performs one of the matrix-vector operations
157 *
158 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
159 *
160 * y := alpha*conjg( A' )*x + beta*y,
161 *
162 * where alpha and beta are scalars, x and y are vectors and A is an
163 * m by n band matrix, with kl sub-diagonals and ku super-diagonals.
164 *
165 * Parameters
166 * ==========
167 *
168 * TRANS - CHARACTER*1.
169 * On entry, TRANS specifies the operation to be performed as
170 * follows:
171 *
172 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
173 *
174 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
175 *
176 * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
177 *
178 * Unchanged on exit.
179 *
180 * M - INTEGER.
181 * On entry, M specifies the number of rows of the matrix A.
182 * M must be at least zero.
183 * Unchanged on exit.
184 *
185 * N - INTEGER.
186 * On entry, N specifies the number of columns of the matrix A.
187 * N must be at least zero.
188 * Unchanged on exit.
189 *
190 * KL - INTEGER.
191 * On entry, KL specifies the number of sub-diagonals of the
192 * matrix A. KL must satisfy 0 .le. KL.
193 * Unchanged on exit.
194 *
195 * KU - INTEGER.
196 * On entry, KU specifies the number of super-diagonals of the
197 * matrix A. KU must satisfy 0 .le. KU.
198 * Unchanged on exit.
199 *
200 * ALPHA - COMPLEX .
201 * On entry, ALPHA specifies the scalar alpha.
202 * Unchanged on exit.
203 *
204 * A - COMPLEX array of DIMENSION ( LDA, n ).
205 * Before entry, the leading ( kl + ku + 1 ) by n part of the
206 * array A must contain the matrix of coefficients, supplied
207 * column by column, with the leading diagonal of the matrix in
208 * row ( ku + 1 ) of the array, the first super-diagonal
209 * starting at position 2 in row ku, the first sub-diagonal
210 * starting at position 1 in row ( ku + 2 ), and so on.
211 * Elements in the array A that do not correspond to elements
212 * in the band matrix (such as the top left ku by ku triangle)
213 * are not referenced.
214 * The following program segment will transfer a band matrix
215 * from conventional full matrix storage to band storage:
216 *
217 * DO 20, J = 1, N
218 * K = KU + 1 - J
219 * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
220 * A( K + I, J ) = matrix( I, J )
221 * 10 CONTINUE
222 * 20 CONTINUE
223 *
224 * Unchanged on exit.
225 *
226 * LDA - INTEGER.
227 * On entry, LDA specifies the first dimension of A as declared
228 * in the calling (sub) program. LDA must be at least
229 * ( kl + ku + 1 ).
230 * Unchanged on exit.
231 *
232 * X - COMPLEX array of DIMENSION at least
233 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
234 * and at least
235 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
236 * Before entry, the incremented array X must contain the
237 * vector x.
238 * Unchanged on exit.
239 *
240 * INCX - INTEGER.
241 * On entry, INCX specifies the increment for the elements of
242 * X. INCX must not be zero.
243 * Unchanged on exit.
244 *
245 * BETA - COMPLEX .
246 * On entry, BETA specifies the scalar beta. When BETA is
247 * supplied as zero then Y need not be set on input.
248 * Unchanged on exit.
249 *
250 * Y - COMPLEX array of DIMENSION at least
251 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
252 * and at least
253 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
254 * Before entry, the incremented array Y must contain the
255 * vector y. On exit, Y is overwritten by the updated vector y.
256 *
257 *
258 * INCY - INTEGER.
259 * On entry, INCY specifies the increment for the elements of
260 * Y. INCY must not be zero.
261 * Unchanged on exit.
262 *
263 *
264 * Level 2 Blas routine.
265 *
266 * -- Written on 22-October-1986.
267 * Jack Dongarra, Argonne National Lab.
268 * Jeremy Du Croz, Nag Central Office.
269 * Sven Hammarling, Nag Central Office.
270 * Richard Hanson, Sandia National Labs.
271 *
272 *
273 * .. Parameters ..
274  COMPLEX ONE
275  parameter( one = ( 1.0e+0, 0.0e+0 ) )
276  COMPLEX ZERO
277  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
278 * .. Local Scalars ..
279  COMPLEX TEMP
280  INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
281  $ lenx, leny
282  LOGICAL NOCONJ
283 * .. External Functions ..
284  LOGICAL LSAME
285  EXTERNAL lsame
286 * .. External Subroutines ..
287  EXTERNAL xerbla
288 * .. Intrinsic Functions ..
289  INTRINSIC conjg, max, min
290 * ..
291 * .. Executable Statements ..
292 *
293 * Test the input parameters.
294 *
295  info = 0
296  IF ( .NOT.lsame( trans, 'N' ).AND.
297  $ .NOT.lsame( trans, 'T' ).AND.
298  $ .NOT.lsame( trans, 'C' ) )THEN
299  info = 1
300  ELSE IF( m.LT.0 )THEN
301  info = 2
302  ELSE IF( n.LT.0 )THEN
303  info = 3
304  ELSE IF( kl.LT.0 )THEN
305  info = 4
306  ELSE IF( ku.LT.0 )THEN
307  info = 5
308  ELSE IF( lda.LT.( kl + ku + 1 ) )THEN
309  info = 8
310  ELSE IF( incx.EQ.0 )THEN
311  info = 10
312  ELSE IF( incy.EQ.0 )THEN
313  info = 13
314  END IF
315  IF( info.NE.0 )THEN
316  CALL xerbla( 'CGBMV ', info )
317  RETURN
318  END IF
319 *
320 * Quick return if possible.
321 *
322  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
323  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
324  $ RETURN
325 *
326  noconj = lsame( trans, 'T' )
327 *
328 * Set LENX and LENY, the lengths of the vectors x and y, and set
329 * up the start points in X and Y.
330 *
331  IF( lsame( trans, 'N' ) )THEN
332  lenx = n
333  leny = m
334  ELSE
335  lenx = m
336  leny = n
337  END IF
338  IF( incx.GT.0 )THEN
339  kx = 1
340  ELSE
341  kx = 1 - ( lenx - 1 )*incx
342  END IF
343  IF( incy.GT.0 )THEN
344  ky = 1
345  ELSE
346  ky = 1 - ( leny - 1 )*incy
347  END IF
348 *
349 * Start the operations. In this version the elements of A are
350 * accessed sequentially with one pass through the band part of A.
351 *
352 * First form y := beta*y.
353 *
354  IF( beta.NE.one )THEN
355  IF( incy.EQ.1 )THEN
356  IF( beta.EQ.zero )THEN
357  DO 10, i = 1, leny
358  y( i ) = zero
359  10 CONTINUE
360  ELSE
361  DO 20, i = 1, leny
362  y( i ) = beta*y( i )
363  20 CONTINUE
364  END IF
365  ELSE
366  iy = ky
367  IF( beta.EQ.zero )THEN
368  DO 30, i = 1, leny
369  y( iy ) = zero
370  iy = iy + incy
371  30 CONTINUE
372  ELSE
373  DO 40, i = 1, leny
374  y( iy ) = beta*y( iy )
375  iy = iy + incy
376  40 CONTINUE
377  END IF
378  END IF
379  END IF
380  IF( alpha.EQ.zero )
381  $ RETURN
382  kup1 = ku + 1
383  IF( lsame( trans, 'N' ) )THEN
384 *
385 * Form y := alpha*A*x + y.
386 *
387  jx = kx
388  IF( incy.EQ.1 )THEN
389  DO 60, j = 1, n
390  IF( x( jx ).NE.zero )THEN
391  temp = alpha*x( jx )
392  k = kup1 - j
393  DO 50, i = max( 1, j - ku ), min( m, j + kl )
394  y( i ) = y( i ) + temp*a( k + i, j )
395  50 CONTINUE
396  END IF
397  jx = jx + incx
398  60 CONTINUE
399  ELSE
400  DO 80, j = 1, n
401  IF( x( jx ).NE.zero )THEN
402  temp = alpha*x( jx )
403  iy = ky
404  k = kup1 - j
405  DO 70, i = max( 1, j - ku ), min( m, j + kl )
406  y( iy ) = y( iy ) + temp*a( k + i, j )
407  iy = iy + incy
408  70 CONTINUE
409  END IF
410  jx = jx + incx
411  IF( j.GT.ku )
412  $ ky = ky + incy
413  80 CONTINUE
414  END IF
415  ELSE
416 *
417 * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
418 *
419  jy = ky
420  IF( incx.EQ.1 )THEN
421  DO 110, j = 1, n
422  temp = zero
423  k = kup1 - j
424  IF( noconj )THEN
425  DO 90, i = max( 1, j - ku ), min( m, j + kl )
426  temp = temp + a( k + i, j )*x( i )
427  90 CONTINUE
428  ELSE
429  DO 100, i = max( 1, j - ku ), min( m, j + kl )
430  temp = temp + conjg( a( k + i, j ) )*x( i )
431  100 CONTINUE
432  END IF
433  y( jy ) = y( jy ) + alpha*temp
434  jy = jy + incy
435  110 CONTINUE
436  ELSE
437  DO 140, j = 1, n
438  temp = zero
439  ix = kx
440  k = kup1 - j
441  IF( noconj )THEN
442  DO 120, i = max( 1, j - ku ), min( m, j + kl )
443  temp = temp + a( k + i, j )*x( ix )
444  ix = ix + incx
445  120 CONTINUE
446  ELSE
447  DO 130, i = max( 1, j - ku ), min( m, j + kl )
448  temp = temp + conjg( a( k + i, j ) )*x( ix )
449  ix = ix + incx
450  130 CONTINUE
451  END IF
452  y( jy ) = y( jy ) + alpha*temp
453  jy = jy + incy
454  IF( j.GT.ku )
455  $ kx = kx + incx
456  140 CONTINUE
457  END IF
458  END IF
459 *
460  RETURN
461 *
462 * End of CGBMV .
463 *
464  END
465  SUBROUTINE cgemm ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
466  $ beta, c, ldc )
467 * .. Scalar Arguments ..
468  CHARACTER*1 TRANSA, TRANSB
469  INTEGER M, N, K, LDA, LDB, LDC
470  COMPLEX ALPHA, BETA
471 * .. Array Arguments ..
472  COMPLEX A( lda, * ), B( ldb, * ), C( ldc, * )
473 * ..
474 *
475 * Purpose
476 * =======
477 *
478 * CGEMM performs one of the matrix-matrix operations
479 *
480 * C := alpha*op( A )*op( B ) + beta*C,
481 *
482 * where op( X ) is one of
483 *
484 * op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ),
485 *
486 * alpha and beta are scalars, and A, B and C are matrices, with op( A )
487 * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
488 *
489 * Parameters
490 * ==========
491 *
492 * TRANSA - CHARACTER*1.
493 * On entry, TRANSA specifies the form of op( A ) to be used in
494 * the matrix multiplication as follows:
495 *
496 * TRANSA = 'N' or 'n', op( A ) = A.
497 *
498 * TRANSA = 'T' or 't', op( A ) = A'.
499 *
500 * TRANSA = 'C' or 'c', op( A ) = conjg( A' ).
501 *
502 * Unchanged on exit.
503 *
504 * TRANSB - CHARACTER*1.
505 * On entry, TRANSB specifies the form of op( B ) to be used in
506 * the matrix multiplication as follows:
507 *
508 * TRANSB = 'N' or 'n', op( B ) = B.
509 *
510 * TRANSB = 'T' or 't', op( B ) = B'.
511 *
512 * TRANSB = 'C' or 'c', op( B ) = conjg( B' ).
513 *
514 * Unchanged on exit.
515 *
516 * M - INTEGER.
517 * On entry, M specifies the number of rows of the matrix
518 * op( A ) and of the matrix C. M must be at least zero.
519 * Unchanged on exit.
520 *
521 * N - INTEGER.
522 * On entry, N specifies the number of columns of the matrix
523 * op( B ) and the number of columns of the matrix C. N must be
524 * at least zero.
525 * Unchanged on exit.
526 *
527 * K - INTEGER.
528 * On entry, K specifies the number of columns of the matrix
529 * op( A ) and the number of rows of the matrix op( B ). K must
530 * be at least zero.
531 * Unchanged on exit.
532 *
533 * ALPHA - COMPLEX .
534 * On entry, ALPHA specifies the scalar alpha.
535 * Unchanged on exit.
536 *
537 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
538 * k when TRANSA = 'N' or 'n', and is m otherwise.
539 * Before entry with TRANSA = 'N' or 'n', the leading m by k
540 * part of the array A must contain the matrix A, otherwise
541 * the leading k by m part of the array A must contain the
542 * matrix A.
543 * Unchanged on exit.
544 *
545 * LDA - INTEGER.
546 * On entry, LDA specifies the first dimension of A as declared
547 * in the calling (sub) program. When TRANSA = 'N' or 'n' then
548 * LDA must be at least max( 1, m ), otherwise LDA must be at
549 * least max( 1, k ).
550 * Unchanged on exit.
551 *
552 * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is
553 * n when TRANSB = 'N' or 'n', and is k otherwise.
554 * Before entry with TRANSB = 'N' or 'n', the leading k by n
555 * part of the array B must contain the matrix B, otherwise
556 * the leading n by k part of the array B must contain the
557 * matrix B.
558 * Unchanged on exit.
559 *
560 * LDB - INTEGER.
561 * On entry, LDB specifies the first dimension of B as declared
562 * in the calling (sub) program. When TRANSB = 'N' or 'n' then
563 * LDB must be at least max( 1, k ), otherwise LDB must be at
564 * least max( 1, n ).
565 * Unchanged on exit.
566 *
567 * BETA - COMPLEX .
568 * On entry, BETA specifies the scalar beta. When BETA is
569 * supplied as zero then C need not be set on input.
570 * Unchanged on exit.
571 *
572 * C - COMPLEX array of DIMENSION ( LDC, n ).
573 * Before entry, the leading m by n part of the array C must
574 * contain the matrix C, except when beta is zero, in which
575 * case C need not be set on entry.
576 * On exit, the array C is overwritten by the m by n matrix
577 * ( alpha*op( A )*op( B ) + beta*C ).
578 *
579 * LDC - INTEGER.
580 * On entry, LDC specifies the first dimension of C as declared
581 * in the calling (sub) program. LDC must be at least
582 * max( 1, m ).
583 * Unchanged on exit.
584 *
585 *
586 * Level 3 Blas routine.
587 *
588 * -- Written on 8-February-1989.
589 * Jack Dongarra, Argonne National Laboratory.
590 * Iain Duff, AERE Harwell.
591 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
592 * Sven Hammarling, Numerical Algorithms Group Ltd.
593 *
594 *
595 * .. External Functions ..
596  LOGICAL LSAME
597  EXTERNAL lsame
598 * .. External Subroutines ..
599  EXTERNAL xerbla
600 * .. Intrinsic Functions ..
601  INTRINSIC conjg, max
602 * .. Local Scalars ..
603  LOGICAL CONJA, CONJB, NOTA, NOTB
604  INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
605  COMPLEX TEMP
606 * .. Parameters ..
607  COMPLEX ONE
608  parameter( one = ( 1.0e+0, 0.0e+0 ) )
609  COMPLEX ZERO
610  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
611 * ..
612 * .. Executable Statements ..
613 *
614 * Set NOTA and NOTB as true if A and B respectively are not
615 * conjugated or transposed, set CONJA and CONJB as true if A and
616 * B respectively are to be transposed but not conjugated and set
617 * NROWA, NCOLA and NROWB as the number of rows and columns of A
618 * and the number of rows of B respectively.
619 *
620  nota = lsame( transa, 'N' )
621  notb = lsame( transb, 'N' )
622  conja = lsame( transa, 'C' )
623  conjb = lsame( transb, 'C' )
624  IF( nota )THEN
625  nrowa = m
626  ncola = k
627  ELSE
628  nrowa = k
629  ncola = m
630  END IF
631  IF( notb )THEN
632  nrowb = k
633  ELSE
634  nrowb = n
635  END IF
636 *
637 * Test the input parameters.
638 *
639  info = 0
640  IF( ( .NOT.nota ).AND.
641  $ ( .NOT.conja ).AND.
642  $ ( .NOT.lsame( transa, 'T' ) ) )THEN
643  info = 1
644  ELSE IF( ( .NOT.notb ).AND.
645  $ ( .NOT.conjb ).AND.
646  $ ( .NOT.lsame( transb, 'T' ) ) )THEN
647  info = 2
648  ELSE IF( m .LT.0 )THEN
649  info = 3
650  ELSE IF( n .LT.0 )THEN
651  info = 4
652  ELSE IF( k .LT.0 )THEN
653  info = 5
654  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
655  info = 8
656  ELSE IF( ldb.LT.max( 1, nrowb ) )THEN
657  info = 10
658  ELSE IF( ldc.LT.max( 1, m ) )THEN
659  info = 13
660  END IF
661  IF( info.NE.0 )THEN
662  CALL xerbla( 'CGEMM ', info )
663  RETURN
664  END IF
665 *
666 * Quick return if possible.
667 *
668  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
669  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
670  $ RETURN
671 *
672 * And when alpha.eq.zero.
673 *
674  IF( alpha.EQ.zero )THEN
675  IF( beta.EQ.zero )THEN
676  DO 20, j = 1, n
677  DO 10, i = 1, m
678  c( i, j ) = zero
679  10 CONTINUE
680  20 CONTINUE
681  ELSE
682  DO 40, j = 1, n
683  DO 30, i = 1, m
684  c( i, j ) = beta*c( i, j )
685  30 CONTINUE
686  40 CONTINUE
687  END IF
688  RETURN
689  END IF
690 *
691 * Start the operations.
692 *
693  IF( notb )THEN
694  IF( nota )THEN
695 *
696 * Form C := alpha*A*B + beta*C.
697 *
698  DO 90, j = 1, n
699  IF( beta.EQ.zero )THEN
700  DO 50, i = 1, m
701  c( i, j ) = zero
702  50 CONTINUE
703  ELSE IF( beta.NE.one )THEN
704  DO 60, i = 1, m
705  c( i, j ) = beta*c( i, j )
706  60 CONTINUE
707  END IF
708  DO 80, l = 1, k
709  IF( b( l, j ).NE.zero )THEN
710  temp = alpha*b( l, j )
711  DO 70, i = 1, m
712  c( i, j ) = c( i, j ) + temp*a( i, l )
713  70 CONTINUE
714  END IF
715  80 CONTINUE
716  90 CONTINUE
717  ELSE IF( conja )THEN
718 *
719 * Form C := alpha*conjg( A' )*B + beta*C.
720 *
721  DO 120, j = 1, n
722  DO 110, i = 1, m
723  temp = zero
724  DO 100, l = 1, k
725  temp = temp + conjg( a( l, i ) )*b( l, j )
726  100 CONTINUE
727  IF( beta.EQ.zero )THEN
728  c( i, j ) = alpha*temp
729  ELSE
730  c( i, j ) = alpha*temp + beta*c( i, j )
731  END IF
732  110 CONTINUE
733  120 CONTINUE
734  ELSE
735 *
736 * Form C := alpha*A'*B + beta*C
737 *
738  DO 150, j = 1, n
739  DO 140, i = 1, m
740  temp = zero
741  DO 130, l = 1, k
742  temp = temp + a( l, i )*b( l, j )
743  130 CONTINUE
744  IF( beta.EQ.zero )THEN
745  c( i, j ) = alpha*temp
746  ELSE
747  c( i, j ) = alpha*temp + beta*c( i, j )
748  END IF
749  140 CONTINUE
750  150 CONTINUE
751  END IF
752  ELSE IF( nota )THEN
753  IF( conjb )THEN
754 *
755 * Form C := alpha*A*conjg( B' ) + beta*C.
756 *
757  DO 200, j = 1, n
758  IF( beta.EQ.zero )THEN
759  DO 160, i = 1, m
760  c( i, j ) = zero
761  160 CONTINUE
762  ELSE IF( beta.NE.one )THEN
763  DO 170, i = 1, m
764  c( i, j ) = beta*c( i, j )
765  170 CONTINUE
766  END IF
767  DO 190, l = 1, k
768  IF( b( j, l ).NE.zero )THEN
769  temp = alpha*conjg( b( j, l ) )
770  DO 180, i = 1, m
771  c( i, j ) = c( i, j ) + temp*a( i, l )
772  180 CONTINUE
773  END IF
774  190 CONTINUE
775  200 CONTINUE
776  ELSE
777 *
778 * Form C := alpha*A*B' + beta*C
779 *
780  DO 250, j = 1, n
781  IF( beta.EQ.zero )THEN
782  DO 210, i = 1, m
783  c( i, j ) = zero
784  210 CONTINUE
785  ELSE IF( beta.NE.one )THEN
786  DO 220, i = 1, m
787  c( i, j ) = beta*c( i, j )
788  220 CONTINUE
789  END IF
790  DO 240, l = 1, k
791  IF( b( j, l ).NE.zero )THEN
792  temp = alpha*b( j, l )
793  DO 230, i = 1, m
794  c( i, j ) = c( i, j ) + temp*a( i, l )
795  230 CONTINUE
796  END IF
797  240 CONTINUE
798  250 CONTINUE
799  END IF
800  ELSE IF( conja )THEN
801  IF( conjb )THEN
802 *
803 * Form C := alpha*conjg( A' )*conjg( B' ) + beta*C.
804 *
805  DO 280, j = 1, n
806  DO 270, i = 1, m
807  temp = zero
808  DO 260, l = 1, k
809  temp = temp + conjg( a( l, i ) )*conjg( b( j, l ) )
810  260 CONTINUE
811  IF( beta.EQ.zero )THEN
812  c( i, j ) = alpha*temp
813  ELSE
814  c( i, j ) = alpha*temp + beta*c( i, j )
815  END IF
816  270 CONTINUE
817  280 CONTINUE
818  ELSE
819 *
820 * Form C := alpha*conjg( A' )*B' + beta*C
821 *
822  DO 310, j = 1, n
823  DO 300, i = 1, m
824  temp = zero
825  DO 290, l = 1, k
826  temp = temp + conjg( a( l, i ) )*b( j, l )
827  290 CONTINUE
828  IF( beta.EQ.zero )THEN
829  c( i, j ) = alpha*temp
830  ELSE
831  c( i, j ) = alpha*temp + beta*c( i, j )
832  END IF
833  300 CONTINUE
834  310 CONTINUE
835  END IF
836  ELSE
837  IF( conjb )THEN
838 *
839 * Form C := alpha*A'*conjg( B' ) + beta*C
840 *
841  DO 340, j = 1, n
842  DO 330, i = 1, m
843  temp = zero
844  DO 320, l = 1, k
845  temp = temp + a( l, i )*conjg( b( j, l ) )
846  320 CONTINUE
847  IF( beta.EQ.zero )THEN
848  c( i, j ) = alpha*temp
849  ELSE
850  c( i, j ) = alpha*temp + beta*c( i, j )
851  END IF
852  330 CONTINUE
853  340 CONTINUE
854  ELSE
855 *
856 * Form C := alpha*A'*B' + beta*C
857 *
858  DO 370, j = 1, n
859  DO 360, i = 1, m
860  temp = zero
861  DO 350, l = 1, k
862  temp = temp + a( l, i )*b( j, l )
863  350 CONTINUE
864  IF( beta.EQ.zero )THEN
865  c( i, j ) = alpha*temp
866  ELSE
867  c( i, j ) = alpha*temp + beta*c( i, j )
868  END IF
869  360 CONTINUE
870  370 CONTINUE
871  END IF
872  END IF
873 *
874  RETURN
875 *
876 * End of CGEMM .
877 *
878  END
879  SUBROUTINE cgemv ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
880  $ beta, y, incy )
881 * .. Scalar Arguments ..
882  COMPLEX ALPHA, BETA
883  INTEGER INCX, INCY, LDA, M, N
884  CHARACTER*1 TRANS
885 * .. Array Arguments ..
886  COMPLEX A( lda, * ), X( * ), Y( * )
887 * ..
888 *
889 * Purpose
890 * =======
891 *
892 * CGEMV performs one of the matrix-vector operations
893 *
894 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
895 *
896 * y := alpha*conjg( A' )*x + beta*y,
897 *
898 * where alpha and beta are scalars, x and y are vectors and A is an
899 * m by n matrix.
900 *
901 * Parameters
902 * ==========
903 *
904 * TRANS - CHARACTER*1.
905 * On entry, TRANS specifies the operation to be performed as
906 * follows:
907 *
908 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
909 *
910 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
911 *
912 * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
913 *
914 * Unchanged on exit.
915 *
916 * M - INTEGER.
917 * On entry, M specifies the number of rows of the matrix A.
918 * M must be at least zero.
919 * Unchanged on exit.
920 *
921 * N - INTEGER.
922 * On entry, N specifies the number of columns of the matrix A.
923 * N must be at least zero.
924 * Unchanged on exit.
925 *
926 * ALPHA - COMPLEX .
927 * On entry, ALPHA specifies the scalar alpha.
928 * Unchanged on exit.
929 *
930 * A - COMPLEX array of DIMENSION ( LDA, n ).
931 * Before entry, the leading m by n part of the array A must
932 * contain the matrix of coefficients.
933 * Unchanged on exit.
934 *
935 * LDA - INTEGER.
936 * On entry, LDA specifies the first dimension of A as declared
937 * in the calling (sub) program. LDA must be at least
938 * max( 1, m ).
939 * Unchanged on exit.
940 *
941 * X - COMPLEX array of DIMENSION at least
942 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
943 * and at least
944 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
945 * Before entry, the incremented array X must contain the
946 * vector x.
947 * Unchanged on exit.
948 *
949 * INCX - INTEGER.
950 * On entry, INCX specifies the increment for the elements of
951 * X. INCX must not be zero.
952 * Unchanged on exit.
953 *
954 * BETA - COMPLEX .
955 * On entry, BETA specifies the scalar beta. When BETA is
956 * supplied as zero then Y need not be set on input.
957 * Unchanged on exit.
958 *
959 * Y - COMPLEX array of DIMENSION at least
960 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
961 * and at least
962 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
963 * Before entry with BETA non-zero, the incremented array Y
964 * must contain the vector y. On exit, Y is overwritten by the
965 * updated vector y.
966 *
967 * INCY - INTEGER.
968 * On entry, INCY specifies the increment for the elements of
969 * Y. INCY must not be zero.
970 * Unchanged on exit.
971 *
972 *
973 * Level 2 Blas routine.
974 *
975 * -- Written on 22-October-1986.
976 * Jack Dongarra, Argonne National Lab.
977 * Jeremy Du Croz, Nag Central Office.
978 * Sven Hammarling, Nag Central Office.
979 * Richard Hanson, Sandia National Labs.
980 *
981 *
982 * .. Parameters ..
983  COMPLEX ONE
984  parameter( one = ( 1.0e+0, 0.0e+0 ) )
985  COMPLEX ZERO
986  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
987 * .. Local Scalars ..
988  COMPLEX TEMP
989  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
990  LOGICAL NOCONJ
991 * .. External Functions ..
992  LOGICAL LSAME
993  EXTERNAL lsame
994 * .. External Subroutines ..
995  EXTERNAL xerbla
996 * .. Intrinsic Functions ..
997  INTRINSIC conjg, max
998 * ..
999 * .. Executable Statements ..
1000 *
1001 * Test the input parameters.
1002 *
1003  info = 0
1004  IF ( .NOT.lsame( trans, 'N' ).AND.
1005  $ .NOT.lsame( trans, 'T' ).AND.
1006  $ .NOT.lsame( trans, 'C' ) )THEN
1007  info = 1
1008  ELSE IF( m.LT.0 )THEN
1009  info = 2
1010  ELSE IF( n.LT.0 )THEN
1011  info = 3
1012  ELSE IF( lda.LT.max( 1, m ) )THEN
1013  info = 6
1014  ELSE IF( incx.EQ.0 )THEN
1015  info = 8
1016  ELSE IF( incy.EQ.0 )THEN
1017  info = 11
1018  END IF
1019  IF( info.NE.0 )THEN
1020  CALL xerbla( 'CGEMV ', info )
1021  RETURN
1022  END IF
1023 *
1024 * Quick return if possible.
1025 *
1026  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
1027  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
1028  $ RETURN
1029 *
1030  noconj = lsame( trans, 'T' )
1031 *
1032 * Set LENX and LENY, the lengths of the vectors x and y, and set
1033 * up the start points in X and Y.
1034 *
1035  IF( lsame( trans, 'N' ) )THEN
1036  lenx = n
1037  leny = m
1038  ELSE
1039  lenx = m
1040  leny = n
1041  END IF
1042  IF( incx.GT.0 )THEN
1043  kx = 1
1044  ELSE
1045  kx = 1 - ( lenx - 1 )*incx
1046  END IF
1047  IF( incy.GT.0 )THEN
1048  ky = 1
1049  ELSE
1050  ky = 1 - ( leny - 1 )*incy
1051  END IF
1052 *
1053 * Start the operations. In this version the elements of A are
1054 * accessed sequentially with one pass through A.
1055 *
1056 * First form y := beta*y.
1057 *
1058  IF( beta.NE.one )THEN
1059  IF( incy.EQ.1 )THEN
1060  IF( beta.EQ.zero )THEN
1061  DO 10, i = 1, leny
1062  y( i ) = zero
1063  10 CONTINUE
1064  ELSE
1065  DO 20, i = 1, leny
1066  y( i ) = beta*y( i )
1067  20 CONTINUE
1068  END IF
1069  ELSE
1070  iy = ky
1071  IF( beta.EQ.zero )THEN
1072  DO 30, i = 1, leny
1073  y( iy ) = zero
1074  iy = iy + incy
1075  30 CONTINUE
1076  ELSE
1077  DO 40, i = 1, leny
1078  y( iy ) = beta*y( iy )
1079  iy = iy + incy
1080  40 CONTINUE
1081  END IF
1082  END IF
1083  END IF
1084  IF( alpha.EQ.zero )
1085  $ RETURN
1086  IF( lsame( trans, 'N' ) )THEN
1087 *
1088 * Form y := alpha*A*x + y.
1089 *
1090  jx = kx
1091  IF( incy.EQ.1 )THEN
1092  DO 60, j = 1, n
1093  IF( x( jx ).NE.zero )THEN
1094  temp = alpha*x( jx )
1095  DO 50, i = 1, m
1096  y( i ) = y( i ) + temp*a( i, j )
1097  50 CONTINUE
1098  END IF
1099  jx = jx + incx
1100  60 CONTINUE
1101  ELSE
1102  DO 80, j = 1, n
1103  IF( x( jx ).NE.zero )THEN
1104  temp = alpha*x( jx )
1105  iy = ky
1106  DO 70, i = 1, m
1107  y( iy ) = y( iy ) + temp*a( i, j )
1108  iy = iy + incy
1109  70 CONTINUE
1110  END IF
1111  jx = jx + incx
1112  80 CONTINUE
1113  END IF
1114  ELSE
1115 *
1116 * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
1117 *
1118  jy = ky
1119  IF( incx.EQ.1 )THEN
1120  DO 110, j = 1, n
1121  temp = zero
1122  IF( noconj )THEN
1123  DO 90, i = 1, m
1124  temp = temp + a( i, j )*x( i )
1125  90 CONTINUE
1126  ELSE
1127  DO 100, i = 1, m
1128  temp = temp + conjg( a( i, j ) )*x( i )
1129  100 CONTINUE
1130  END IF
1131  y( jy ) = y( jy ) + alpha*temp
1132  jy = jy + incy
1133  110 CONTINUE
1134  ELSE
1135  DO 140, j = 1, n
1136  temp = zero
1137  ix = kx
1138  IF( noconj )THEN
1139  DO 120, i = 1, m
1140  temp = temp + a( i, j )*x( ix )
1141  ix = ix + incx
1142  120 CONTINUE
1143  ELSE
1144  DO 130, i = 1, m
1145  temp = temp + conjg( a( i, j ) )*x( ix )
1146  ix = ix + incx
1147  130 CONTINUE
1148  END IF
1149  y( jy ) = y( jy ) + alpha*temp
1150  jy = jy + incy
1151  140 CONTINUE
1152  END IF
1153  END IF
1154 *
1155  RETURN
1156 *
1157 * End of CGEMV .
1158 *
1159  END
1160  SUBROUTINE cgerc ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
1161 * .. Scalar Arguments ..
1162  COMPLEX ALPHA
1163  INTEGER INCX, INCY, LDA, M, N
1164 * .. Array Arguments ..
1165  COMPLEX A( lda, * ), X( * ), Y( * )
1166 * ..
1167 *
1168 * Purpose
1169 * =======
1170 *
1171 * CGERC performs the rank 1 operation
1172 *
1173 * A := alpha*x*conjg( y' ) + A,
1174 *
1175 * where alpha is a scalar, x is an m element vector, y is an n element
1176 * vector and A is an m by n matrix.
1177 *
1178 * Parameters
1179 * ==========
1180 *
1181 * M - INTEGER.
1182 * On entry, M specifies the number of rows of the matrix A.
1183 * M must be at least zero.
1184 * Unchanged on exit.
1185 *
1186 * N - INTEGER.
1187 * On entry, N specifies the number of columns of the matrix A.
1188 * N must be at least zero.
1189 * Unchanged on exit.
1190 *
1191 * ALPHA - COMPLEX .
1192 * On entry, ALPHA specifies the scalar alpha.
1193 * Unchanged on exit.
1194 *
1195 * X - COMPLEX array of dimension at least
1196 * ( 1 + ( m - 1 )*abs( INCX ) ).
1197 * Before entry, the incremented array X must contain the m
1198 * element vector x.
1199 * Unchanged on exit.
1200 *
1201 * INCX - INTEGER.
1202 * On entry, INCX specifies the increment for the elements of
1203 * X. INCX must not be zero.
1204 * Unchanged on exit.
1205 *
1206 * Y - COMPLEX array of dimension at least
1207 * ( 1 + ( n - 1 )*abs( INCY ) ).
1208 * Before entry, the incremented array Y must contain the n
1209 * element vector y.
1210 * Unchanged on exit.
1211 *
1212 * INCY - INTEGER.
1213 * On entry, INCY specifies the increment for the elements of
1214 * Y. INCY must not be zero.
1215 * Unchanged on exit.
1216 *
1217 * A - COMPLEX array of DIMENSION ( LDA, n ).
1218 * Before entry, the leading m by n part of the array A must
1219 * contain the matrix of coefficients. On exit, A is
1220 * overwritten by the updated matrix.
1221 *
1222 * LDA - INTEGER.
1223 * On entry, LDA specifies the first dimension of A as declared
1224 * in the calling (sub) program. LDA must be at least
1225 * max( 1, m ).
1226 * Unchanged on exit.
1227 *
1228 *
1229 * Level 2 Blas routine.
1230 *
1231 * -- Written on 22-October-1986.
1232 * Jack Dongarra, Argonne National Lab.
1233 * Jeremy Du Croz, Nag Central Office.
1234 * Sven Hammarling, Nag Central Office.
1235 * Richard Hanson, Sandia National Labs.
1236 *
1237 *
1238 * .. Parameters ..
1239  COMPLEX ZERO
1240  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
1241 * .. Local Scalars ..
1242  COMPLEX TEMP
1243  INTEGER I, INFO, IX, J, JY, KX
1244 * .. External Subroutines ..
1245  EXTERNAL xerbla
1246 * .. Intrinsic Functions ..
1247  INTRINSIC conjg, max
1248 * ..
1249 * .. Executable Statements ..
1250 *
1251 * Test the input parameters.
1252 *
1253  info = 0
1254  IF ( m.LT.0 )THEN
1255  info = 1
1256  ELSE IF( n.LT.0 )THEN
1257  info = 2
1258  ELSE IF( incx.EQ.0 )THEN
1259  info = 5
1260  ELSE IF( incy.EQ.0 )THEN
1261  info = 7
1262  ELSE IF( lda.LT.max( 1, m ) )THEN
1263  info = 9
1264  END IF
1265  IF( info.NE.0 )THEN
1266  CALL xerbla( 'CGERC ', info )
1267  RETURN
1268  END IF
1269 *
1270 * Quick return if possible.
1271 *
1272  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
1273  $ RETURN
1274 *
1275 * Start the operations. In this version the elements of A are
1276 * accessed sequentially with one pass through A.
1277 *
1278  IF( incy.GT.0 )THEN
1279  jy = 1
1280  ELSE
1281  jy = 1 - ( n - 1 )*incy
1282  END IF
1283  IF( incx.EQ.1 )THEN
1284  DO 20, j = 1, n
1285  IF( y( jy ).NE.zero )THEN
1286  temp = alpha*conjg( y( jy ) )
1287  DO 10, i = 1, m
1288  a( i, j ) = a( i, j ) + x( i )*temp
1289  10 CONTINUE
1290  END IF
1291  jy = jy + incy
1292  20 CONTINUE
1293  ELSE
1294  IF( incx.GT.0 )THEN
1295  kx = 1
1296  ELSE
1297  kx = 1 - ( m - 1 )*incx
1298  END IF
1299  DO 40, j = 1, n
1300  IF( y( jy ).NE.zero )THEN
1301  temp = alpha*conjg( y( jy ) )
1302  ix = kx
1303  DO 30, i = 1, m
1304  a( i, j ) = a( i, j ) + x( ix )*temp
1305  ix = ix + incx
1306  30 CONTINUE
1307  END IF
1308  jy = jy + incy
1309  40 CONTINUE
1310  END IF
1311 *
1312  RETURN
1313 *
1314 * End of CGERC .
1315 *
1316  END
1317  SUBROUTINE cgeru ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
1318 * .. Scalar Arguments ..
1319  COMPLEX ALPHA
1320  INTEGER INCX, INCY, LDA, M, N
1321 * .. Array Arguments ..
1322  COMPLEX A( lda, * ), X( * ), Y( * )
1323 * ..
1324 *
1325 * Purpose
1326 * =======
1327 *
1328 * CGERU performs the rank 1 operation
1329 *
1330 * A := alpha*x*y' + A,
1331 *
1332 * where alpha is a scalar, x is an m element vector, y is an n element
1333 * vector and A is an m by n matrix.
1334 *
1335 * Parameters
1336 * ==========
1337 *
1338 * M - INTEGER.
1339 * On entry, M specifies the number of rows of the matrix A.
1340 * M must be at least zero.
1341 * Unchanged on exit.
1342 *
1343 * N - INTEGER.
1344 * On entry, N specifies the number of columns of the matrix A.
1345 * N must be at least zero.
1346 * Unchanged on exit.
1347 *
1348 * ALPHA - COMPLEX .
1349 * On entry, ALPHA specifies the scalar alpha.
1350 * Unchanged on exit.
1351 *
1352 * X - COMPLEX array of dimension at least
1353 * ( 1 + ( m - 1 )*abs( INCX ) ).
1354 * Before entry, the incremented array X must contain the m
1355 * element vector x.
1356 * Unchanged on exit.
1357 *
1358 * INCX - INTEGER.
1359 * On entry, INCX specifies the increment for the elements of
1360 * X. INCX must not be zero.
1361 * Unchanged on exit.
1362 *
1363 * Y - COMPLEX array of dimension at least
1364 * ( 1 + ( n - 1 )*abs( INCY ) ).
1365 * Before entry, the incremented array Y must contain the n
1366 * element vector y.
1367 * Unchanged on exit.
1368 *
1369 * INCY - INTEGER.
1370 * On entry, INCY specifies the increment for the elements of
1371 * Y. INCY must not be zero.
1372 * Unchanged on exit.
1373 *
1374 * A - COMPLEX array of DIMENSION ( LDA, n ).
1375 * Before entry, the leading m by n part of the array A must
1376 * contain the matrix of coefficients. On exit, A is
1377 * overwritten by the updated matrix.
1378 *
1379 * LDA - INTEGER.
1380 * On entry, LDA specifies the first dimension of A as declared
1381 * in the calling (sub) program. LDA must be at least
1382 * max( 1, m ).
1383 * Unchanged on exit.
1384 *
1385 *
1386 * Level 2 Blas routine.
1387 *
1388 * -- Written on 22-October-1986.
1389 * Jack Dongarra, Argonne National Lab.
1390 * Jeremy Du Croz, Nag Central Office.
1391 * Sven Hammarling, Nag Central Office.
1392 * Richard Hanson, Sandia National Labs.
1393 *
1394 *
1395 * .. Parameters ..
1396  COMPLEX ZERO
1397  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
1398 * .. Local Scalars ..
1399  COMPLEX TEMP
1400  INTEGER I, INFO, IX, J, JY, KX
1401 * .. External Subroutines ..
1402  EXTERNAL xerbla
1403 * .. Intrinsic Functions ..
1404  INTRINSIC max
1405 * ..
1406 * .. Executable Statements ..
1407 *
1408 * Test the input parameters.
1409 *
1410  info = 0
1411  IF ( m.LT.0 )THEN
1412  info = 1
1413  ELSE IF( n.LT.0 )THEN
1414  info = 2
1415  ELSE IF( incx.EQ.0 )THEN
1416  info = 5
1417  ELSE IF( incy.EQ.0 )THEN
1418  info = 7
1419  ELSE IF( lda.LT.max( 1, m ) )THEN
1420  info = 9
1421  END IF
1422  IF( info.NE.0 )THEN
1423  CALL xerbla( 'CGERU ', info )
1424  RETURN
1425  END IF
1426 *
1427 * Quick return if possible.
1428 *
1429  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
1430  $ RETURN
1431 *
1432 * Start the operations. In this version the elements of A are
1433 * accessed sequentially with one pass through A.
1434 *
1435  IF( incy.GT.0 )THEN
1436  jy = 1
1437  ELSE
1438  jy = 1 - ( n - 1 )*incy
1439  END IF
1440  IF( incx.EQ.1 )THEN
1441  DO 20, j = 1, n
1442  IF( y( jy ).NE.zero )THEN
1443  temp = alpha*y( jy )
1444  DO 10, i = 1, m
1445  a( i, j ) = a( i, j ) + x( i )*temp
1446  10 CONTINUE
1447  END IF
1448  jy = jy + incy
1449  20 CONTINUE
1450  ELSE
1451  IF( incx.GT.0 )THEN
1452  kx = 1
1453  ELSE
1454  kx = 1 - ( m - 1 )*incx
1455  END IF
1456  DO 40, j = 1, n
1457  IF( y( jy ).NE.zero )THEN
1458  temp = alpha*y( jy )
1459  ix = kx
1460  DO 30, i = 1, m
1461  a( i, j ) = a( i, j ) + x( ix )*temp
1462  ix = ix + incx
1463  30 CONTINUE
1464  END IF
1465  jy = jy + incy
1466  40 CONTINUE
1467  END IF
1468 *
1469  RETURN
1470 *
1471 * End of CGERU .
1472 *
1473  END
1474  SUBROUTINE chbmv ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
1475  $ beta, y, incy )
1476 * .. Scalar Arguments ..
1477  COMPLEX ALPHA, BETA
1478  INTEGER INCX, INCY, K, LDA, N
1479  CHARACTER*1 UPLO
1480 * .. Array Arguments ..
1481  COMPLEX A( lda, * ), X( * ), Y( * )
1482 * ..
1483 *
1484 * Purpose
1485 * =======
1486 *
1487 * CHBMV performs the matrix-vector operation
1488 *
1489 * y := alpha*A*x + beta*y,
1490 *
1491 * where alpha and beta are scalars, x and y are n element vectors and
1492 * A is an n by n hermitian band matrix, with k super-diagonals.
1493 *
1494 * Parameters
1495 * ==========
1496 *
1497 * UPLO - CHARACTER*1.
1498 * On entry, UPLO specifies whether the upper or lower
1499 * triangular part of the band matrix A is being supplied as
1500 * follows:
1501 *
1502 * UPLO = 'U' or 'u' The upper triangular part of A is
1503 * being supplied.
1504 *
1505 * UPLO = 'L' or 'l' The lower triangular part of A is
1506 * being supplied.
1507 *
1508 * Unchanged on exit.
1509 *
1510 * N - INTEGER.
1511 * On entry, N specifies the order of the matrix A.
1512 * N must be at least zero.
1513 * Unchanged on exit.
1514 *
1515 * K - INTEGER.
1516 * On entry, K specifies the number of super-diagonals of the
1517 * matrix A. K must satisfy 0 .le. K.
1518 * Unchanged on exit.
1519 *
1520 * ALPHA - COMPLEX .
1521 * On entry, ALPHA specifies the scalar alpha.
1522 * Unchanged on exit.
1523 *
1524 * A - COMPLEX array of DIMENSION ( LDA, n ).
1525 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
1526 * by n part of the array A must contain the upper triangular
1527 * band part of the hermitian matrix, supplied column by
1528 * column, with the leading diagonal of the matrix in row
1529 * ( k + 1 ) of the array, the first super-diagonal starting at
1530 * position 2 in row k, and so on. The top left k by k triangle
1531 * of the array A is not referenced.
1532 * The following program segment will transfer the upper
1533 * triangular part of a hermitian band matrix from conventional
1534 * full matrix storage to band storage:
1535 *
1536 * DO 20, J = 1, N
1537 * M = K + 1 - J
1538 * DO 10, I = MAX( 1, J - K ), J
1539 * A( M + I, J ) = matrix( I, J )
1540 * 10 CONTINUE
1541 * 20 CONTINUE
1542 *
1543 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
1544 * by n part of the array A must contain the lower triangular
1545 * band part of the hermitian matrix, supplied column by
1546 * column, with the leading diagonal of the matrix in row 1 of
1547 * the array, the first sub-diagonal starting at position 1 in
1548 * row 2, and so on. The bottom right k by k triangle of the
1549 * array A is not referenced.
1550 * The following program segment will transfer the lower
1551 * triangular part of a hermitian band matrix from conventional
1552 * full matrix storage to band storage:
1553 *
1554 * DO 20, J = 1, N
1555 * M = 1 - J
1556 * DO 10, I = J, MIN( N, J + K )
1557 * A( M + I, J ) = matrix( I, J )
1558 * 10 CONTINUE
1559 * 20 CONTINUE
1560 *
1561 * Note that the imaginary parts of the diagonal elements need
1562 * not be set and are assumed to be zero.
1563 * Unchanged on exit.
1564 *
1565 * LDA - INTEGER.
1566 * On entry, LDA specifies the first dimension of A as declared
1567 * in the calling (sub) program. LDA must be at least
1568 * ( k + 1 ).
1569 * Unchanged on exit.
1570 *
1571 * X - COMPLEX array of DIMENSION at least
1572 * ( 1 + ( n - 1 )*abs( INCX ) ).
1573 * Before entry, the incremented array X must contain the
1574 * vector x.
1575 * Unchanged on exit.
1576 *
1577 * INCX - INTEGER.
1578 * On entry, INCX specifies the increment for the elements of
1579 * X. INCX must not be zero.
1580 * Unchanged on exit.
1581 *
1582 * BETA - COMPLEX .
1583 * On entry, BETA specifies the scalar beta.
1584 * Unchanged on exit.
1585 *
1586 * Y - COMPLEX array of DIMENSION at least
1587 * ( 1 + ( n - 1 )*abs( INCY ) ).
1588 * Before entry, the incremented array Y must contain the
1589 * vector y. On exit, Y is overwritten by the updated vector y.
1590 *
1591 * INCY - INTEGER.
1592 * On entry, INCY specifies the increment for the elements of
1593 * Y. INCY must not be zero.
1594 * Unchanged on exit.
1595 *
1596 *
1597 * Level 2 Blas routine.
1598 *
1599 * -- Written on 22-October-1986.
1600 * Jack Dongarra, Argonne National Lab.
1601 * Jeremy Du Croz, Nag Central Office.
1602 * Sven Hammarling, Nag Central Office.
1603 * Richard Hanson, Sandia National Labs.
1604 *
1605 *
1606 * .. Parameters ..
1607  COMPLEX ONE
1608  parameter( one = ( 1.0e+0, 0.0e+0 ) )
1609  COMPLEX ZERO
1610  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
1611 * .. Local Scalars ..
1612  COMPLEX TEMP1, TEMP2
1613  INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
1614 * .. External Functions ..
1615  LOGICAL LSAME
1616  EXTERNAL lsame
1617 * .. External Subroutines ..
1618  EXTERNAL xerbla
1619 * .. Intrinsic Functions ..
1620  INTRINSIC conjg, max, min, real
1621 * ..
1622 * .. Executable Statements ..
1623 *
1624 * Test the input parameters.
1625 *
1626  info = 0
1627  IF ( .NOT.lsame( uplo, 'U' ).AND.
1628  $ .NOT.lsame( uplo, 'L' ) )THEN
1629  info = 1
1630  ELSE IF( n.LT.0 )THEN
1631  info = 2
1632  ELSE IF( k.LT.0 )THEN
1633  info = 3
1634  ELSE IF( lda.LT.( k + 1 ) )THEN
1635  info = 6
1636  ELSE IF( incx.EQ.0 )THEN
1637  info = 8
1638  ELSE IF( incy.EQ.0 )THEN
1639  info = 11
1640  END IF
1641  IF( info.NE.0 )THEN
1642  CALL xerbla( 'CHBMV ', info )
1643  RETURN
1644  END IF
1645 *
1646 * Quick return if possible.
1647 *
1648  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
1649  $ RETURN
1650 *
1651 * Set up the start points in X and Y.
1652 *
1653  IF( incx.GT.0 )THEN
1654  kx = 1
1655  ELSE
1656  kx = 1 - ( n - 1 )*incx
1657  END IF
1658  IF( incy.GT.0 )THEN
1659  ky = 1
1660  ELSE
1661  ky = 1 - ( n - 1 )*incy
1662  END IF
1663 *
1664 * Start the operations. In this version the elements of the array A
1665 * are accessed sequentially with one pass through A.
1666 *
1667 * First form y := beta*y.
1668 *
1669  IF( beta.NE.one )THEN
1670  IF( incy.EQ.1 )THEN
1671  IF( beta.EQ.zero )THEN
1672  DO 10, i = 1, n
1673  y( i ) = zero
1674  10 CONTINUE
1675  ELSE
1676  DO 20, i = 1, n
1677  y( i ) = beta*y( i )
1678  20 CONTINUE
1679  END IF
1680  ELSE
1681  iy = ky
1682  IF( beta.EQ.zero )THEN
1683  DO 30, i = 1, n
1684  y( iy ) = zero
1685  iy = iy + incy
1686  30 CONTINUE
1687  ELSE
1688  DO 40, i = 1, n
1689  y( iy ) = beta*y( iy )
1690  iy = iy + incy
1691  40 CONTINUE
1692  END IF
1693  END IF
1694  END IF
1695  IF( alpha.EQ.zero )
1696  $ RETURN
1697  IF( lsame( uplo, 'U' ) )THEN
1698 *
1699 * Form y when upper triangle of A is stored.
1700 *
1701  kplus1 = k + 1
1702  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
1703  DO 60, j = 1, n
1704  temp1 = alpha*x( j )
1705  temp2 = zero
1706  l = kplus1 - j
1707  DO 50, i = max( 1, j - k ), j - 1
1708  y( i ) = y( i ) + temp1*a( l + i, j )
1709  temp2 = temp2 + conjg( a( l + i, j ) )*x( i )
1710  50 CONTINUE
1711  y( j ) = y( j ) + temp1*REAL( A( KPLUS1, J ) )
1712  $ + alpha*temp2
1713  60 CONTINUE
1714  ELSE
1715  jx = kx
1716  jy = ky
1717  DO 80, j = 1, n
1718  temp1 = alpha*x( jx )
1719  temp2 = zero
1720  ix = kx
1721  iy = ky
1722  l = kplus1 - j
1723  DO 70, i = max( 1, j - k ), j - 1
1724  y( iy ) = y( iy ) + temp1*a( l + i, j )
1725  temp2 = temp2 + conjg( a( l + i, j ) )*x( ix )
1726  ix = ix + incx
1727  iy = iy + incy
1728  70 CONTINUE
1729  y( jy ) = y( jy ) + temp1*REAL( A( KPLUS1, J ) )
1730  $ + alpha*temp2
1731  jx = jx + incx
1732  jy = jy + incy
1733  IF( j.GT.k )THEN
1734  kx = kx + incx
1735  ky = ky + incy
1736  END IF
1737  80 CONTINUE
1738  END IF
1739  ELSE
1740 *
1741 * Form y when lower triangle of A is stored.
1742 *
1743  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
1744  DO 100, j = 1, n
1745  temp1 = alpha*x( j )
1746  temp2 = zero
1747  y( j ) = y( j ) + temp1*REAL( A( 1, J ) )
1748  l = 1 - j
1749  DO 90, i = j + 1, min( n, j + k )
1750  y( i ) = y( i ) + temp1*a( l + i, j )
1751  temp2 = temp2 + conjg( a( l + i, j ) )*x( i )
1752  90 CONTINUE
1753  y( j ) = y( j ) + alpha*temp2
1754  100 CONTINUE
1755  ELSE
1756  jx = kx
1757  jy = ky
1758  DO 120, j = 1, n
1759  temp1 = alpha*x( jx )
1760  temp2 = zero
1761  y( jy ) = y( jy ) + temp1*REAL( A( 1, J ) )
1762  l = 1 - j
1763  ix = jx
1764  iy = jy
1765  DO 110, i = j + 1, min( n, j + k )
1766  ix = ix + incx
1767  iy = iy + incy
1768  y( iy ) = y( iy ) + temp1*a( l + i, j )
1769  temp2 = temp2 + conjg( a( l + i, j ) )*x( ix )
1770  110 CONTINUE
1771  y( jy ) = y( jy ) + alpha*temp2
1772  jx = jx + incx
1773  jy = jy + incy
1774  120 CONTINUE
1775  END IF
1776  END IF
1777 *
1778  RETURN
1779 *
1780 * End of CHBMV .
1781 *
1782  END
1783  SUBROUTINE chemm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
1784  $ beta, c, ldc )
1785 * .. Scalar Arguments ..
1786  CHARACTER*1 SIDE, UPLO
1787  INTEGER M, N, LDA, LDB, LDC
1788  COMPLEX ALPHA, BETA
1789 * .. Array Arguments ..
1790  COMPLEX A( lda, * ), B( ldb, * ), C( ldc, * )
1791 * ..
1792 *
1793 * Purpose
1794 * =======
1795 *
1796 * CHEMM performs one of the matrix-matrix operations
1797 *
1798 * C := alpha*A*B + beta*C,
1799 *
1800 * or
1801 *
1802 * C := alpha*B*A + beta*C,
1803 *
1804 * where alpha and beta are scalars, A is an hermitian matrix and B and
1805 * C are m by n matrices.
1806 *
1807 * Parameters
1808 * ==========
1809 *
1810 * SIDE - CHARACTER*1.
1811 * On entry, SIDE specifies whether the hermitian matrix A
1812 * appears on the left or right in the operation as follows:
1813 *
1814 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
1815 *
1816 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
1817 *
1818 * Unchanged on exit.
1819 *
1820 * UPLO - CHARACTER*1.
1821 * On entry, UPLO specifies whether the upper or lower
1822 * triangular part of the hermitian matrix A is to be
1823 * referenced as follows:
1824 *
1825 * UPLO = 'U' or 'u' Only the upper triangular part of the
1826 * hermitian matrix is to be referenced.
1827 *
1828 * UPLO = 'L' or 'l' Only the lower triangular part of the
1829 * hermitian matrix is to be referenced.
1830 *
1831 * Unchanged on exit.
1832 *
1833 * M - INTEGER.
1834 * On entry, M specifies the number of rows of the matrix C.
1835 * M must be at least zero.
1836 * Unchanged on exit.
1837 *
1838 * N - INTEGER.
1839 * On entry, N specifies the number of columns of the matrix C.
1840 * N must be at least zero.
1841 * Unchanged on exit.
1842 *
1843 * ALPHA - COMPLEX .
1844 * On entry, ALPHA specifies the scalar alpha.
1845 * Unchanged on exit.
1846 *
1847 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
1848 * m when SIDE = 'L' or 'l' and is n otherwise.
1849 * Before entry with SIDE = 'L' or 'l', the m by m part of
1850 * the array A must contain the hermitian matrix, such that
1851 * when UPLO = 'U' or 'u', the leading m by m upper triangular
1852 * part of the array A must contain the upper triangular part
1853 * of the hermitian matrix and the strictly lower triangular
1854 * part of A is not referenced, and when UPLO = 'L' or 'l',
1855 * the leading m by m lower triangular part of the array A
1856 * must contain the lower triangular part of the hermitian
1857 * matrix and the strictly upper triangular part of A is not
1858 * referenced.
1859 * Before entry with SIDE = 'R' or 'r', the n by n part of
1860 * the array A must contain the hermitian matrix, such that
1861 * when UPLO = 'U' or 'u', the leading n by n upper triangular
1862 * part of the array A must contain the upper triangular part
1863 * of the hermitian matrix and the strictly lower triangular
1864 * part of A is not referenced, and when UPLO = 'L' or 'l',
1865 * the leading n by n lower triangular part of the array A
1866 * must contain the lower triangular part of the hermitian
1867 * matrix and the strictly upper triangular part of A is not
1868 * referenced.
1869 * Note that the imaginary parts of the diagonal elements need
1870 * not be set, they are assumed to be zero.
1871 * Unchanged on exit.
1872 *
1873 * LDA - INTEGER.
1874 * On entry, LDA specifies the first dimension of A as declared
1875 * in the calling (sub) program. When SIDE = 'L' or 'l' then
1876 * LDA must be at least max( 1, m ), otherwise LDA must be at
1877 * least max( 1, n ).
1878 * Unchanged on exit.
1879 *
1880 * B - COMPLEX array of DIMENSION ( LDB, n ).
1881 * Before entry, the leading m by n part of the array B must
1882 * contain the matrix B.
1883 * Unchanged on exit.
1884 *
1885 * LDB - INTEGER.
1886 * On entry, LDB specifies the first dimension of B as declared
1887 * in the calling (sub) program. LDB must be at least
1888 * max( 1, m ).
1889 * Unchanged on exit.
1890 *
1891 * BETA - COMPLEX .
1892 * On entry, BETA specifies the scalar beta. When BETA is
1893 * supplied as zero then C need not be set on input.
1894 * Unchanged on exit.
1895 *
1896 * C - COMPLEX array of DIMENSION ( LDC, n ).
1897 * Before entry, the leading m by n part of the array C must
1898 * contain the matrix C, except when beta is zero, in which
1899 * case C need not be set on entry.
1900 * On exit, the array C is overwritten by the m by n updated
1901 * matrix.
1902 *
1903 * LDC - INTEGER.
1904 * On entry, LDC specifies the first dimension of C as declared
1905 * in the calling (sub) program. LDC must be at least
1906 * max( 1, m ).
1907 * Unchanged on exit.
1908 *
1909 *
1910 * Level 3 Blas routine.
1911 *
1912 * -- Written on 8-February-1989.
1913 * Jack Dongarra, Argonne National Laboratory.
1914 * Iain Duff, AERE Harwell.
1915 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1916 * Sven Hammarling, Numerical Algorithms Group Ltd.
1917 *
1918 *
1919 * .. External Functions ..
1920  LOGICAL LSAME
1921  EXTERNAL lsame
1922 * .. External Subroutines ..
1923  EXTERNAL xerbla
1924 * .. Intrinsic Functions ..
1925  INTRINSIC conjg, max, real
1926 * .. Local Scalars ..
1927  LOGICAL UPPER
1928  INTEGER I, INFO, J, K, NROWA
1929  COMPLEX TEMP1, TEMP2
1930 * .. Parameters ..
1931  COMPLEX ONE
1932  parameter( one = ( 1.0e+0, 0.0e+0 ) )
1933  COMPLEX ZERO
1934  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
1935 * ..
1936 * .. Executable Statements ..
1937 *
1938 * Set NROWA as the number of rows of A.
1939 *
1940  IF( lsame( side, 'L' ) )THEN
1941  nrowa = m
1942  ELSE
1943  nrowa = n
1944  END IF
1945  upper = lsame( uplo, 'U' )
1946 *
1947 * Test the input parameters.
1948 *
1949  info = 0
1950  IF( ( .NOT.lsame( side, 'L' ) ).AND.
1951  $ ( .NOT.lsame( side, 'R' ) ) )THEN
1952  info = 1
1953  ELSE IF( ( .NOT.upper ).AND.
1954  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
1955  info = 2
1956  ELSE IF( m .LT.0 )THEN
1957  info = 3
1958  ELSE IF( n .LT.0 )THEN
1959  info = 4
1960  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
1961  info = 7
1962  ELSE IF( ldb.LT.max( 1, m ) )THEN
1963  info = 9
1964  ELSE IF( ldc.LT.max( 1, m ) )THEN
1965  info = 12
1966  END IF
1967  IF( info.NE.0 )THEN
1968  CALL xerbla( 'CHEMM ', info )
1969  RETURN
1970  END IF
1971 *
1972 * Quick return if possible.
1973 *
1974  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
1975  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
1976  $ RETURN
1977 *
1978 * And when alpha.eq.zero.
1979 *
1980  IF( alpha.EQ.zero )THEN
1981  IF( beta.EQ.zero )THEN
1982  DO 20, j = 1, n
1983  DO 10, i = 1, m
1984  c( i, j ) = zero
1985  10 CONTINUE
1986  20 CONTINUE
1987  ELSE
1988  DO 40, j = 1, n
1989  DO 30, i = 1, m
1990  c( i, j ) = beta*c( i, j )
1991  30 CONTINUE
1992  40 CONTINUE
1993  END IF
1994  RETURN
1995  END IF
1996 *
1997 * Start the operations.
1998 *
1999  IF( lsame( side, 'L' ) )THEN
2000 *
2001 * Form C := alpha*A*B + beta*C.
2002 *
2003  IF( upper )THEN
2004  DO 70, j = 1, n
2005  DO 60, i = 1, m
2006  temp1 = alpha*b( i, j )
2007  temp2 = zero
2008  DO 50, k = 1, i - 1
2009  c( k, j ) = c( k, j ) + temp1*a( k, i )
2010  temp2 = temp2 +
2011  $ b( k, j )*conjg( a( k, i ) )
2012  50 CONTINUE
2013  IF( beta.EQ.zero )THEN
2014  c( i, j ) = temp1*REAL( A( I, I ) ) +
2015  $ alpha*temp2
2016  ELSE
2017  c( i, j ) = beta *c( i, j ) +
2018  $ temp1*REAL( A( I, I ) ) +
2019  $ alpha*temp2
2020  END IF
2021  60 CONTINUE
2022  70 CONTINUE
2023  ELSE
2024  DO 100, j = 1, n
2025  DO 90, i = m, 1, -1
2026  temp1 = alpha*b( i, j )
2027  temp2 = zero
2028  DO 80, k = i + 1, m
2029  c( k, j ) = c( k, j ) + temp1*a( k, i )
2030  temp2 = temp2 +
2031  $ b( k, j )*conjg( a( k, i ) )
2032  80 CONTINUE
2033  IF( beta.EQ.zero )THEN
2034  c( i, j ) = temp1*REAL( A( I, I ) ) +
2035  $ alpha*temp2
2036  ELSE
2037  c( i, j ) = beta *c( i, j ) +
2038  $ temp1*REAL( A( I, I ) ) +
2039  $ alpha*temp2
2040  END IF
2041  90 CONTINUE
2042  100 CONTINUE
2043  END IF
2044  ELSE
2045 *
2046 * Form C := alpha*B*A + beta*C.
2047 *
2048  DO 170, j = 1, n
2049  temp1 = alpha*REAL( A( J, J ) )
2050  IF( beta.EQ.zero )THEN
2051  DO 110, i = 1, m
2052  c( i, j ) = temp1*b( i, j )
2053  110 CONTINUE
2054  ELSE
2055  DO 120, i = 1, m
2056  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
2057  120 CONTINUE
2058  END IF
2059  DO 140, k = 1, j - 1
2060  IF( upper )THEN
2061  temp1 = alpha*a( k, j )
2062  ELSE
2063  temp1 = alpha*conjg( a( j, k ) )
2064  END IF
2065  DO 130, i = 1, m
2066  c( i, j ) = c( i, j ) + temp1*b( i, k )
2067  130 CONTINUE
2068  140 CONTINUE
2069  DO 160, k = j + 1, n
2070  IF( upper )THEN
2071  temp1 = alpha*conjg( a( j, k ) )
2072  ELSE
2073  temp1 = alpha*a( k, j )
2074  END IF
2075  DO 150, i = 1, m
2076  c( i, j ) = c( i, j ) + temp1*b( i, k )
2077  150 CONTINUE
2078  160 CONTINUE
2079  170 CONTINUE
2080  END IF
2081 *
2082  RETURN
2083 *
2084 * End of CHEMM .
2085 *
2086  END
2087  SUBROUTINE chemv ( UPLO, N, ALPHA, A, LDA, X, INCX,
2088  $ beta, y, incy )
2089 * .. Scalar Arguments ..
2090  COMPLEX ALPHA, BETA
2091  INTEGER INCX, INCY, LDA, N
2092  CHARACTER*1 UPLO
2093 * .. Array Arguments ..
2094  COMPLEX A( lda, * ), X( * ), Y( * )
2095 * ..
2096 *
2097 * Purpose
2098 * =======
2099 *
2100 * CHEMV performs the matrix-vector operation
2101 *
2102 * y := alpha*A*x + beta*y,
2103 *
2104 * where alpha and beta are scalars, x and y are n element vectors and
2105 * A is an n by n hermitian matrix.
2106 *
2107 * Parameters
2108 * ==========
2109 *
2110 * UPLO - CHARACTER*1.
2111 * On entry, UPLO specifies whether the upper or lower
2112 * triangular part of the array A is to be referenced as
2113 * follows:
2114 *
2115 * UPLO = 'U' or 'u' Only the upper triangular part of A
2116 * is to be referenced.
2117 *
2118 * UPLO = 'L' or 'l' Only the lower triangular part of A
2119 * is to be referenced.
2120 *
2121 * Unchanged on exit.
2122 *
2123 * N - INTEGER.
2124 * On entry, N specifies the order of the matrix A.
2125 * N must be at least zero.
2126 * Unchanged on exit.
2127 *
2128 * ALPHA - COMPLEX .
2129 * On entry, ALPHA specifies the scalar alpha.
2130 * Unchanged on exit.
2131 *
2132 * A - COMPLEX array of DIMENSION ( LDA, n ).
2133 * Before entry with UPLO = 'U' or 'u', the leading n by n
2134 * upper triangular part of the array A must contain the upper
2135 * triangular part of the hermitian matrix and the strictly
2136 * lower triangular part of A is not referenced.
2137 * Before entry with UPLO = 'L' or 'l', the leading n by n
2138 * lower triangular part of the array A must contain the lower
2139 * triangular part of the hermitian matrix and the strictly
2140 * upper triangular part of A is not referenced.
2141 * Note that the imaginary parts of the diagonal elements need
2142 * not be set and are assumed to be zero.
2143 * Unchanged on exit.
2144 *
2145 * LDA - INTEGER.
2146 * On entry, LDA specifies the first dimension of A as declared
2147 * in the calling (sub) program. LDA must be at least
2148 * max( 1, n ).
2149 * Unchanged on exit.
2150 *
2151 * X - COMPLEX array of dimension at least
2152 * ( 1 + ( n - 1 )*abs( INCX ) ).
2153 * Before entry, the incremented array X must contain the n
2154 * element vector x.
2155 * Unchanged on exit.
2156 *
2157 * INCX - INTEGER.
2158 * On entry, INCX specifies the increment for the elements of
2159 * X. INCX must not be zero.
2160 * Unchanged on exit.
2161 *
2162 * BETA - COMPLEX .
2163 * On entry, BETA specifies the scalar beta. When BETA is
2164 * supplied as zero then Y need not be set on input.
2165 * Unchanged on exit.
2166 *
2167 * Y - COMPLEX array of dimension at least
2168 * ( 1 + ( n - 1 )*abs( INCY ) ).
2169 * Before entry, the incremented array Y must contain the n
2170 * element vector y. On exit, Y is overwritten by the updated
2171 * vector y.
2172 *
2173 * INCY - INTEGER.
2174 * On entry, INCY specifies the increment for the elements of
2175 * Y. INCY must not be zero.
2176 * Unchanged on exit.
2177 *
2178 *
2179 * Level 2 Blas routine.
2180 *
2181 * -- Written on 22-October-1986.
2182 * Jack Dongarra, Argonne National Lab.
2183 * Jeremy Du Croz, Nag Central Office.
2184 * Sven Hammarling, Nag Central Office.
2185 * Richard Hanson, Sandia National Labs.
2186 *
2187 *
2188 * .. Parameters ..
2189  COMPLEX ONE
2190  parameter( one = ( 1.0e+0, 0.0e+0 ) )
2191  COMPLEX ZERO
2192  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
2193 * .. Local Scalars ..
2194  COMPLEX TEMP1, TEMP2
2195  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
2196 * .. External Functions ..
2197  LOGICAL LSAME
2198  EXTERNAL lsame
2199 * .. External Subroutines ..
2200  EXTERNAL xerbla
2201 * .. Intrinsic Functions ..
2202  INTRINSIC conjg, max, real
2203 * ..
2204 * .. Executable Statements ..
2205 *
2206 * Test the input parameters.
2207 *
2208  info = 0
2209  IF ( .NOT.lsame( uplo, 'U' ).AND.
2210  $ .NOT.lsame( uplo, 'L' ) )THEN
2211  info = 1
2212  ELSE IF( n.LT.0 )THEN
2213  info = 2
2214  ELSE IF( lda.LT.max( 1, n ) )THEN
2215  info = 5
2216  ELSE IF( incx.EQ.0 )THEN
2217  info = 7
2218  ELSE IF( incy.EQ.0 )THEN
2219  info = 10
2220  END IF
2221  IF( info.NE.0 )THEN
2222  CALL xerbla( 'CHEMV ', info )
2223  RETURN
2224  END IF
2225 *
2226 * Quick return if possible.
2227 *
2228  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
2229  $ RETURN
2230 *
2231 * Set up the start points in X and Y.
2232 *
2233  IF( incx.GT.0 )THEN
2234  kx = 1
2235  ELSE
2236  kx = 1 - ( n - 1 )*incx
2237  END IF
2238  IF( incy.GT.0 )THEN
2239  ky = 1
2240  ELSE
2241  ky = 1 - ( n - 1 )*incy
2242  END IF
2243 *
2244 * Start the operations. In this version the elements of A are
2245 * accessed sequentially with one pass through the triangular part
2246 * of A.
2247 *
2248 * First form y := beta*y.
2249 *
2250  IF( beta.NE.one )THEN
2251  IF( incy.EQ.1 )THEN
2252  IF( beta.EQ.zero )THEN
2253  DO 10, i = 1, n
2254  y( i ) = zero
2255  10 CONTINUE
2256  ELSE
2257  DO 20, i = 1, n
2258  y( i ) = beta*y( i )
2259  20 CONTINUE
2260  END IF
2261  ELSE
2262  iy = ky
2263  IF( beta.EQ.zero )THEN
2264  DO 30, i = 1, n
2265  y( iy ) = zero
2266  iy = iy + incy
2267  30 CONTINUE
2268  ELSE
2269  DO 40, i = 1, n
2270  y( iy ) = beta*y( iy )
2271  iy = iy + incy
2272  40 CONTINUE
2273  END IF
2274  END IF
2275  END IF
2276  IF( alpha.EQ.zero )
2277  $ RETURN
2278  IF( lsame( uplo, 'U' ) )THEN
2279 *
2280 * Form y when A is stored in upper triangle.
2281 *
2282  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
2283  DO 60, j = 1, n
2284  temp1 = alpha*x( j )
2285  temp2 = zero
2286  DO 50, i = 1, j - 1
2287  y( i ) = y( i ) + temp1*a( i, j )
2288  temp2 = temp2 + conjg( a( i, j ) )*x( i )
2289  50 CONTINUE
2290  y( j ) = y( j ) + temp1*REAL( A( J, J ) ) + ALPHA*TEMP2
2291  60 CONTINUE
2292  ELSE
2293  jx = kx
2294  jy = ky
2295  DO 80, j = 1, n
2296  temp1 = alpha*x( jx )
2297  temp2 = zero
2298  ix = kx
2299  iy = ky
2300  DO 70, i = 1, j - 1
2301  y( iy ) = y( iy ) + temp1*a( i, j )
2302  temp2 = temp2 + conjg( a( i, j ) )*x( ix )
2303  ix = ix + incx
2304  iy = iy + incy
2305  70 CONTINUE
2306  y( jy ) = y( jy ) + temp1*REAL( A( J, J ) ) + ALPHA*TEMP2
2307  jx = jx + incx
2308  jy = jy + incy
2309  80 CONTINUE
2310  END IF
2311  ELSE
2312 *
2313 * Form y when A is stored in lower triangle.
2314 *
2315  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
2316  DO 100, j = 1, n
2317  temp1 = alpha*x( j )
2318  temp2 = zero
2319  y( j ) = y( j ) + temp1*REAL( A( J, J ) )
2320  DO 90, i = j + 1, n
2321  y( i ) = y( i ) + temp1*a( i, j )
2322  temp2 = temp2 + conjg( a( i, j ) )*x( i )
2323  90 CONTINUE
2324  y( j ) = y( j ) + alpha*temp2
2325  100 CONTINUE
2326  ELSE
2327  jx = kx
2328  jy = ky
2329  DO 120, j = 1, n
2330  temp1 = alpha*x( jx )
2331  temp2 = zero
2332  y( jy ) = y( jy ) + temp1*REAL( A( J, J ) )
2333  ix = jx
2334  iy = jy
2335  DO 110, i = j + 1, n
2336  ix = ix + incx
2337  iy = iy + incy
2338  y( iy ) = y( iy ) + temp1*a( i, j )
2339  temp2 = temp2 + conjg( a( i, j ) )*x( ix )
2340  110 CONTINUE
2341  y( jy ) = y( jy ) + alpha*temp2
2342  jx = jx + incx
2343  jy = jy + incy
2344  120 CONTINUE
2345  END IF
2346  END IF
2347 *
2348  RETURN
2349 *
2350 * End of CHEMV .
2351 *
2352  END
2353  SUBROUTINE cher2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
2354 * .. Scalar Arguments ..
2355  COMPLEX ALPHA
2356  INTEGER INCX, INCY, LDA, N
2357  CHARACTER*1 UPLO
2358 * .. Array Arguments ..
2359  COMPLEX A( lda, * ), X( * ), Y( * )
2360 * ..
2361 *
2362 * Purpose
2363 * =======
2364 *
2365 * CHER2 performs the hermitian rank 2 operation
2366 *
2367 * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
2368 *
2369 * where alpha is a scalar, x and y are n element vectors and A is an n
2370 * by n hermitian matrix.
2371 *
2372 * Parameters
2373 * ==========
2374 *
2375 * UPLO - CHARACTER*1.
2376 * On entry, UPLO specifies whether the upper or lower
2377 * triangular part of the array A is to be referenced as
2378 * follows:
2379 *
2380 * UPLO = 'U' or 'u' Only the upper triangular part of A
2381 * is to be referenced.
2382 *
2383 * UPLO = 'L' or 'l' Only the lower triangular part of A
2384 * is to be referenced.
2385 *
2386 * Unchanged on exit.
2387 *
2388 * N - INTEGER.
2389 * On entry, N specifies the order of the matrix A.
2390 * N must be at least zero.
2391 * Unchanged on exit.
2392 *
2393 * ALPHA - COMPLEX .
2394 * On entry, ALPHA specifies the scalar alpha.
2395 * Unchanged on exit.
2396 *
2397 * X - COMPLEX array of dimension at least
2398 * ( 1 + ( n - 1 )*abs( INCX ) ).
2399 * Before entry, the incremented array X must contain the n
2400 * element vector x.
2401 * Unchanged on exit.
2402 *
2403 * INCX - INTEGER.
2404 * On entry, INCX specifies the increment for the elements of
2405 * X. INCX must not be zero.
2406 * Unchanged on exit.
2407 *
2408 * Y - COMPLEX array of dimension at least
2409 * ( 1 + ( n - 1 )*abs( INCY ) ).
2410 * Before entry, the incremented array Y must contain the n
2411 * element vector y.
2412 * Unchanged on exit.
2413 *
2414 * INCY - INTEGER.
2415 * On entry, INCY specifies the increment for the elements of
2416 * Y. INCY must not be zero.
2417 * Unchanged on exit.
2418 *
2419 * A - COMPLEX array of DIMENSION ( LDA, n ).
2420 * Before entry with UPLO = 'U' or 'u', the leading n by n
2421 * upper triangular part of the array A must contain the upper
2422 * triangular part of the hermitian matrix and the strictly
2423 * lower triangular part of A is not referenced. On exit, the
2424 * upper triangular part of the array A is overwritten by the
2425 * upper triangular part of the updated matrix.
2426 * Before entry with UPLO = 'L' or 'l', the leading n by n
2427 * lower triangular part of the array A must contain the lower
2428 * triangular part of the hermitian matrix and the strictly
2429 * upper triangular part of A is not referenced. On exit, the
2430 * lower triangular part of the array A is overwritten by the
2431 * lower triangular part of the updated matrix.
2432 * Note that the imaginary parts of the diagonal elements need
2433 * not be set, they are assumed to be zero, and on exit they
2434 * are set to zero.
2435 *
2436 * LDA - INTEGER.
2437 * On entry, LDA specifies the first dimension of A as declared
2438 * in the calling (sub) program. LDA must be at least
2439 * max( 1, n ).
2440 * Unchanged on exit.
2441 *
2442 *
2443 * Level 2 Blas routine.
2444 *
2445 * -- Written on 22-October-1986.
2446 * Jack Dongarra, Argonne National Lab.
2447 * Jeremy Du Croz, Nag Central Office.
2448 * Sven Hammarling, Nag Central Office.
2449 * Richard Hanson, Sandia National Labs.
2450 *
2451 *
2452 * .. Parameters ..
2453  COMPLEX ZERO
2454  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
2455 * .. Local Scalars ..
2456  COMPLEX TEMP1, TEMP2
2457  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
2458 * .. External Functions ..
2459  LOGICAL LSAME
2460  EXTERNAL lsame
2461 * .. External Subroutines ..
2462  EXTERNAL xerbla
2463 * .. Intrinsic Functions ..
2464  INTRINSIC conjg, max, real
2465 * ..
2466 * .. Executable Statements ..
2467 *
2468 * Test the input parameters.
2469 *
2470  info = 0
2471  IF ( .NOT.lsame( uplo, 'U' ).AND.
2472  $ .NOT.lsame( uplo, 'L' ) )THEN
2473  info = 1
2474  ELSE IF( n.LT.0 )THEN
2475  info = 2
2476  ELSE IF( incx.EQ.0 )THEN
2477  info = 5
2478  ELSE IF( incy.EQ.0 )THEN
2479  info = 7
2480  ELSE IF( lda.LT.max( 1, n ) )THEN
2481  info = 9
2482  END IF
2483  IF( info.NE.0 )THEN
2484  CALL xerbla( 'CHER2 ', info )
2485  RETURN
2486  END IF
2487 *
2488 * Quick return if possible.
2489 *
2490  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
2491  $ RETURN
2492 *
2493 * Set up the start points in X and Y if the increments are not both
2494 * unity.
2495 *
2496  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
2497  IF( incx.GT.0 )THEN
2498  kx = 1
2499  ELSE
2500  kx = 1 - ( n - 1 )*incx
2501  END IF
2502  IF( incy.GT.0 )THEN
2503  ky = 1
2504  ELSE
2505  ky = 1 - ( n - 1 )*incy
2506  END IF
2507  jx = kx
2508  jy = ky
2509  END IF
2510 *
2511 * Start the operations. In this version the elements of A are
2512 * accessed sequentially with one pass through the triangular part
2513 * of A.
2514 *
2515  IF( lsame( uplo, 'U' ) )THEN
2516 *
2517 * Form A when A is stored in the upper triangle.
2518 *
2519  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
2520  DO 20, j = 1, n
2521  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
2522  temp1 = alpha*conjg( y( j ) )
2523  temp2 = conjg( alpha*x( j ) )
2524  DO 10, i = 1, j - 1
2525  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
2526  10 CONTINUE
2527  a( j, j ) = REAL( A( J, J ) ) +
2528  $ REAL( x( j )*temp1 + y( j )*temp2 )
2529  ELSE
2530  a( j, j ) = REAL( A( J, J ) )
2531  END IF
2532  20 CONTINUE
2533  ELSE
2534  DO 40, j = 1, n
2535  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
2536  temp1 = alpha*conjg( y( jy ) )
2537  temp2 = conjg( alpha*x( jx ) )
2538  ix = kx
2539  iy = ky
2540  DO 30, i = 1, j - 1
2541  a( i, j ) = a( i, j ) + x( ix )*temp1
2542  $ + y( iy )*temp2
2543  ix = ix + incx
2544  iy = iy + incy
2545  30 CONTINUE
2546  a( j, j ) = REAL( A( J, J ) ) +
2547  $ REAL( x( jx )*temp1 + y( jy )*temp2 )
2548  ELSE
2549  a( j, j ) = REAL( A( J, J ) )
2550  END IF
2551  jx = jx + incx
2552  jy = jy + incy
2553  40 CONTINUE
2554  END IF
2555  ELSE
2556 *
2557 * Form A when A is stored in the lower triangle.
2558 *
2559  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
2560  DO 60, j = 1, n
2561  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
2562  temp1 = alpha*conjg( y( j ) )
2563  temp2 = conjg( alpha*x( j ) )
2564  a( j, j ) = REAL( A( J, J ) ) +
2565  $ REAL( x( j )*temp1 + y( j )*temp2 )
2566  DO 50, i = j + 1, n
2567  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
2568  50 CONTINUE
2569  ELSE
2570  a( j, j ) = REAL( A( J, J ) )
2571  END IF
2572  60 CONTINUE
2573  ELSE
2574  DO 80, j = 1, n
2575  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
2576  temp1 = alpha*conjg( y( jy ) )
2577  temp2 = conjg( alpha*x( jx ) )
2578  a( j, j ) = REAL( A( J, J ) ) +
2579  $ REAL( x( jx )*temp1 + y( jy )*temp2 )
2580  ix = jx
2581  iy = jy
2582  DO 70, i = j + 1, n
2583  ix = ix + incx
2584  iy = iy + incy
2585  a( i, j ) = a( i, j ) + x( ix )*temp1
2586  $ + y( iy )*temp2
2587  70 CONTINUE
2588  ELSE
2589  a( j, j ) = REAL( A( J, J ) )
2590  END IF
2591  jx = jx + incx
2592  jy = jy + incy
2593  80 CONTINUE
2594  END IF
2595  END IF
2596 *
2597  RETURN
2598 *
2599 * End of CHER2 .
2600 *
2601  END
2602  SUBROUTINE cher2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
2603  $ beta, c, ldc )
2604 * .. Scalar Arguments ..
2605  CHARACTER*1 UPLO, TRANS
2606  INTEGER N, K, LDA, LDB, LDC
2607  REAL BETA
2608  COMPLEX ALPHA
2609 * .. Array Arguments ..
2610  COMPLEX A( lda, * ), B( ldb, * ), C( ldc, * )
2611 * ..
2612 *
2613 * Purpose
2614 * =======
2615 *
2616 * CHER2K performs one of the hermitian rank 2k operations
2617 *
2618 * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C,
2619 *
2620 * or
2621 *
2622 * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C,
2623 *
2624 * where alpha and beta are scalars with beta real, C is an n by n
2625 * hermitian matrix and A and B are n by k matrices in the first case
2626 * and k by n matrices in the second case.
2627 *
2628 * Parameters
2629 * ==========
2630 *
2631 * UPLO - CHARACTER*1.
2632 * On entry, UPLO specifies whether the upper or lower
2633 * triangular part of the array C is to be referenced as
2634 * follows:
2635 *
2636 * UPLO = 'U' or 'u' Only the upper triangular part of C
2637 * is to be referenced.
2638 *
2639 * UPLO = 'L' or 'l' Only the lower triangular part of C
2640 * is to be referenced.
2641 *
2642 * Unchanged on exit.
2643 *
2644 * TRANS - CHARACTER*1.
2645 * On entry, TRANS specifies the operation to be performed as
2646 * follows:
2647 *
2648 * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) +
2649 * conjg( alpha )*B*conjg( A' ) +
2650 * beta*C.
2651 *
2652 * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B +
2653 * conjg( alpha )*conjg( B' )*A +
2654 * beta*C.
2655 *
2656 * Unchanged on exit.
2657 *
2658 * N - INTEGER.
2659 * On entry, N specifies the order of the matrix C. N must be
2660 * at least zero.
2661 * Unchanged on exit.
2662 *
2663 * K - INTEGER.
2664 * On entry with TRANS = 'N' or 'n', K specifies the number
2665 * of columns of the matrices A and B, and on entry with
2666 * TRANS = 'C' or 'c', K specifies the number of rows of the
2667 * matrices A and B. K must be at least zero.
2668 * Unchanged on exit.
2669 *
2670 * ALPHA - COMPLEX .
2671 * On entry, ALPHA specifies the scalar alpha.
2672 * Unchanged on exit.
2673 *
2674 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
2675 * k when TRANS = 'N' or 'n', and is n otherwise.
2676 * Before entry with TRANS = 'N' or 'n', the leading n by k
2677 * part of the array A must contain the matrix A, otherwise
2678 * the leading k by n part of the array A must contain the
2679 * matrix A.
2680 * Unchanged on exit.
2681 *
2682 * LDA - INTEGER.
2683 * On entry, LDA specifies the first dimension of A as declared
2684 * in the calling (sub) program. When TRANS = 'N' or 'n'
2685 * then LDA must be at least max( 1, n ), otherwise LDA must
2686 * be at least max( 1, k ).
2687 * Unchanged on exit.
2688 *
2689 * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is
2690 * k when TRANS = 'N' or 'n', and is n otherwise.
2691 * Before entry with TRANS = 'N' or 'n', the leading n by k
2692 * part of the array B must contain the matrix B, otherwise
2693 * the leading k by n part of the array B must contain the
2694 * matrix B.
2695 * Unchanged on exit.
2696 *
2697 * LDB - INTEGER.
2698 * On entry, LDB specifies the first dimension of B as declared
2699 * in the calling (sub) program. When TRANS = 'N' or 'n'
2700 * then LDB must be at least max( 1, n ), otherwise LDB must
2701 * be at least max( 1, k ).
2702 * Unchanged on exit.
2703 *
2704 * BETA - REAL .
2705 * On entry, BETA specifies the scalar beta.
2706 * Unchanged on exit.
2707 *
2708 * C - COMPLEX array of DIMENSION ( LDC, n ).
2709 * Before entry with UPLO = 'U' or 'u', the leading n by n
2710 * upper triangular part of the array C must contain the upper
2711 * triangular part of the hermitian matrix and the strictly
2712 * lower triangular part of C is not referenced. On exit, the
2713 * upper triangular part of the array C is overwritten by the
2714 * upper triangular part of the updated matrix.
2715 * Before entry with UPLO = 'L' or 'l', the leading n by n
2716 * lower triangular part of the array C must contain the lower
2717 * triangular part of the hermitian matrix and the strictly
2718 * upper triangular part of C is not referenced. On exit, the
2719 * lower triangular part of the array C is overwritten by the
2720 * lower triangular part of the updated matrix.
2721 * Note that the imaginary parts of the diagonal elements need
2722 * not be set, they are assumed to be zero, and on exit they
2723 * are set to zero.
2724 *
2725 * LDC - INTEGER.
2726 * On entry, LDC specifies the first dimension of C as declared
2727 * in the calling (sub) program. LDC must be at least
2728 * max( 1, n ).
2729 * Unchanged on exit.
2730 *
2731 *
2732 * Level 3 Blas routine.
2733 *
2734 * -- Written on 8-February-1989.
2735 * Jack Dongarra, Argonne National Laboratory.
2736 * Iain Duff, AERE Harwell.
2737 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2738 * Sven Hammarling, Numerical Algorithms Group Ltd.
2739 *
2740 * -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
2741 * Ed Anderson, Cray Research Inc.
2742 *
2743 *
2744 * .. External Functions ..
2745  LOGICAL LSAME
2746  EXTERNAL lsame
2747 * .. External Subroutines ..
2748  EXTERNAL xerbla
2749 * .. Intrinsic Functions ..
2750  INTRINSIC conjg, max, real
2751 * .. Local Scalars ..
2752  LOGICAL UPPER
2753  INTEGER I, INFO, J, L, NROWA
2754  COMPLEX TEMP1, TEMP2
2755 * .. Parameters ..
2756  REAL ONE
2757  parameter( one = 1.0e+0 )
2758  COMPLEX ZERO
2759  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
2760 * ..
2761 * .. Executable Statements ..
2762 *
2763 * Test the input parameters.
2764 *
2765  IF( lsame( trans, 'N' ) )THEN
2766  nrowa = n
2767  ELSE
2768  nrowa = k
2769  END IF
2770  upper = lsame( uplo, 'U' )
2771 *
2772  info = 0
2773  IF( ( .NOT.upper ).AND.
2774  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
2775  info = 1
2776  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
2777  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
2778  info = 2
2779  ELSE IF( n .LT.0 )THEN
2780  info = 3
2781  ELSE IF( k .LT.0 )THEN
2782  info = 4
2783  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
2784  info = 7
2785  ELSE IF( ldb.LT.max( 1, nrowa ) )THEN
2786  info = 9
2787  ELSE IF( ldc.LT.max( 1, n ) )THEN
2788  info = 12
2789  END IF
2790  IF( info.NE.0 )THEN
2791  CALL xerbla( 'CHER2K', info )
2792  RETURN
2793  END IF
2794 *
2795 * Quick return if possible.
2796 *
2797  IF( ( n.EQ.0 ).OR.
2798  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
2799  $ RETURN
2800 *
2801 * And when alpha.eq.zero.
2802 *
2803  IF( alpha.EQ.zero )THEN
2804  IF( upper )THEN
2805  IF( beta.EQ.REAL( ZERO ) )then
2806  DO 20, j = 1, n
2807  DO 10, i = 1, j
2808  c( i, j ) = zero
2809  10 CONTINUE
2810  20 CONTINUE
2811  ELSE
2812  DO 40, j = 1, n
2813  DO 30, i = 1, j - 1
2814  c( i, j ) = beta*c( i, j )
2815  30 CONTINUE
2816  c( j, j ) = beta*REAL( C( J, J ) )
2817  40 CONTINUE
2818  END IF
2819  ELSE
2820  IF( beta.EQ.REAL( ZERO ) )then
2821  DO 60, j = 1, n
2822  DO 50, i = j, n
2823  c( i, j ) = zero
2824  50 CONTINUE
2825  60 CONTINUE
2826  ELSE
2827  DO 80, j = 1, n
2828  c( j, j ) = beta*REAL( C( J, J ) )
2829  DO 70, i = j + 1, n
2830  c( i, j ) = beta*c( i, j )
2831  70 CONTINUE
2832  80 CONTINUE
2833  END IF
2834  END IF
2835  RETURN
2836  END IF
2837 *
2838 * Start the operations.
2839 *
2840  IF( lsame( trans, 'N' ) )THEN
2841 *
2842 * Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) +
2843 * C.
2844 *
2845  IF( upper )THEN
2846  DO 130, j = 1, n
2847  IF( beta.EQ.REAL( ZERO ) )then
2848  DO 90, i = 1, j
2849  c( i, j ) = zero
2850  90 CONTINUE
2851  ELSE IF( beta.NE.one )THEN
2852  DO 100, i = 1, j - 1
2853  c( i, j ) = beta*c( i, j )
2854  100 CONTINUE
2855  c( j, j ) = beta*REAL( C( J, J ) )
2856  ELSE
2857  c( j, j ) = REAL( C( J, J ) )
2858  END IF
2859  DO 120, l = 1, k
2860  IF( ( a( j, l ).NE.zero ).OR.
2861  $ ( b( j, l ).NE.zero ) )THEN
2862  temp1 = alpha*conjg( b( j, l ) )
2863  temp2 = conjg( alpha*a( j, l ) )
2864  DO 110, i = 1, j - 1
2865  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
2866  $ b( i, l )*temp2
2867  110 CONTINUE
2868  c( j, j ) = REAL( C( J, J ) ) +
2869  $ REAL( a( j, l )*temp1 +
2870  $ b( j, l )*temp2 )
2871  END IF
2872  120 CONTINUE
2873  130 CONTINUE
2874  ELSE
2875  DO 180, j = 1, n
2876  IF( beta.EQ.REAL( ZERO ) )then
2877  DO 140, i = j, n
2878  c( i, j ) = zero
2879  140 CONTINUE
2880  ELSE IF( beta.NE.one )THEN
2881  DO 150, i = j + 1, n
2882  c( i, j ) = beta*c( i, j )
2883  150 CONTINUE
2884  c( j, j ) = beta*REAL( C( J, J ) )
2885  ELSE
2886  c( j, j ) = REAL( C( J, J ) )
2887  END IF
2888  DO 170, l = 1, k
2889  IF( ( a( j, l ).NE.zero ).OR.
2890  $ ( b( j, l ).NE.zero ) )THEN
2891  temp1 = alpha*conjg( b( j, l ) )
2892  temp2 = conjg( alpha*a( j, l ) )
2893  DO 160, i = j + 1, n
2894  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
2895  $ b( i, l )*temp2
2896  160 CONTINUE
2897  c( j, j ) = REAL( C( J, J ) ) +
2898  $ REAL( a( j, l )*temp1 +
2899  $ b( j, l )*temp2 )
2900  END IF
2901  170 CONTINUE
2902  180 CONTINUE
2903  END IF
2904  ELSE
2905 *
2906 * Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A +
2907 * C.
2908 *
2909  IF( upper )THEN
2910  DO 210, j = 1, n
2911  DO 200, i = 1, j
2912  temp1 = zero
2913  temp2 = zero
2914  DO 190, l = 1, k
2915  temp1 = temp1 + conjg( a( l, i ) )*b( l, j )
2916  temp2 = temp2 + conjg( b( l, i ) )*a( l, j )
2917  190 CONTINUE
2918  IF( i.EQ.j )THEN
2919  IF( beta.EQ.REAL( ZERO ) )then
2920  c( j, j ) = REAL( alpha *temp1 +
2921  $ conjg( alpha )*temp2 )
2922  ELSE
2923  c( j, j ) = beta*REAL( C( J, J ) ) +
2924  $ REAL( alpha *temp1 +
2925  $ conjg( alpha )*temp2 )
2926  END IF
2927  ELSE
2928  IF( beta.EQ.REAL( ZERO ) )then
2929  c( i, j ) = alpha*temp1 + conjg( alpha )*temp2
2930  ELSE
2931  c( i, j ) = beta *c( i, j ) +
2932  $ alpha*temp1 + conjg( alpha )*temp2
2933  END IF
2934  END IF
2935  200 CONTINUE
2936  210 CONTINUE
2937  ELSE
2938  DO 240, j = 1, n
2939  DO 230, i = j, n
2940  temp1 = zero
2941  temp2 = zero
2942  DO 220, l = 1, k
2943  temp1 = temp1 + conjg( a( l, i ) )*b( l, j )
2944  temp2 = temp2 + conjg( b( l, i ) )*a( l, j )
2945  220 CONTINUE
2946  IF( i.EQ.j )THEN
2947  IF( beta.EQ.REAL( ZERO ) )then
2948  c( j, j ) = REAL( alpha *temp1 +
2949  $ conjg( alpha )*temp2 )
2950  ELSE
2951  c( j, j ) = beta*REAL( C( J, J ) ) +
2952  $ REAL( alpha *temp1 +
2953  $ conjg( alpha )*temp2 )
2954  END IF
2955  ELSE
2956  IF( beta.EQ.REAL( ZERO ) )then
2957  c( i, j ) = alpha*temp1 + conjg( alpha )*temp2
2958  ELSE
2959  c( i, j ) = beta *c( i, j ) +
2960  $ alpha*temp1 + conjg( alpha )*temp2
2961  END IF
2962  END IF
2963  230 CONTINUE
2964  240 CONTINUE
2965  END IF
2966  END IF
2967 *
2968  RETURN
2969 *
2970 * End of CHER2K.
2971 *
2972  END
2973  SUBROUTINE cher ( UPLO, N, ALPHA, X, INCX, A, LDA )
2974 * .. Scalar Arguments ..
2975  REAL ALPHA
2976  INTEGER INCX, LDA, N
2977  CHARACTER*1 UPLO
2978 * .. Array Arguments ..
2979  COMPLEX A( lda, * ), X( * )
2980 * ..
2981 *
2982 * Purpose
2983 * =======
2984 *
2985 * CHER performs the hermitian rank 1 operation
2986 *
2987 * A := alpha*x*conjg( x' ) + A,
2988 *
2989 * where alpha is a real scalar, x is an n element vector and A is an
2990 * n by n hermitian matrix.
2991 *
2992 * Parameters
2993 * ==========
2994 *
2995 * UPLO - CHARACTER*1.
2996 * On entry, UPLO specifies whether the upper or lower
2997 * triangular part of the array A is to be referenced as
2998 * follows:
2999 *
3000 * UPLO = 'U' or 'u' Only the upper triangular part of A
3001 * is to be referenced.
3002 *
3003 * UPLO = 'L' or 'l' Only the lower triangular part of A
3004 * is to be referenced.
3005 *
3006 * Unchanged on exit.
3007 *
3008 * N - INTEGER.
3009 * On entry, N specifies the order of the matrix A.
3010 * N must be at least zero.
3011 * Unchanged on exit.
3012 *
3013 * ALPHA - REAL .
3014 * On entry, ALPHA specifies the scalar alpha.
3015 * Unchanged on exit.
3016 *
3017 * X - COMPLEX array of dimension at least
3018 * ( 1 + ( n - 1 )*abs( INCX ) ).
3019 * Before entry, the incremented array X must contain the n
3020 * element vector x.
3021 * Unchanged on exit.
3022 *
3023 * INCX - INTEGER.
3024 * On entry, INCX specifies the increment for the elements of
3025 * X. INCX must not be zero.
3026 * Unchanged on exit.
3027 *
3028 * A - COMPLEX array of DIMENSION ( LDA, n ).
3029 * Before entry with UPLO = 'U' or 'u', the leading n by n
3030 * upper triangular part of the array A must contain the upper
3031 * triangular part of the hermitian matrix and the strictly
3032 * lower triangular part of A is not referenced. On exit, the
3033 * upper triangular part of the array A is overwritten by the
3034 * upper triangular part of the updated matrix.
3035 * Before entry with UPLO = 'L' or 'l', the leading n by n
3036 * lower triangular part of the array A must contain the lower
3037 * triangular part of the hermitian matrix and the strictly
3038 * upper triangular part of A is not referenced. On exit, the
3039 * lower triangular part of the array A is overwritten by the
3040 * lower triangular part of the updated matrix.
3041 * Note that the imaginary parts of the diagonal elements need
3042 * not be set, they are assumed to be zero, and on exit they
3043 * are set to zero.
3044 *
3045 * LDA - INTEGER.
3046 * On entry, LDA specifies the first dimension of A as declared
3047 * in the calling (sub) program. LDA must be at least
3048 * max( 1, n ).
3049 * Unchanged on exit.
3050 *
3051 *
3052 * Level 2 Blas routine.
3053 *
3054 * -- Written on 22-October-1986.
3055 * Jack Dongarra, Argonne National Lab.
3056 * Jeremy Du Croz, Nag Central Office.
3057 * Sven Hammarling, Nag Central Office.
3058 * Richard Hanson, Sandia National Labs.
3059 *
3060 *
3061 * .. Parameters ..
3062  COMPLEX ZERO
3063  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
3064 * .. Local Scalars ..
3065  COMPLEX TEMP
3066  INTEGER I, INFO, IX, J, JX, KX
3067 * .. External Functions ..
3068  LOGICAL LSAME
3069  EXTERNAL lsame
3070 * .. External Subroutines ..
3071  EXTERNAL xerbla
3072 * .. Intrinsic Functions ..
3073  INTRINSIC conjg, max, real
3074 * ..
3075 * .. Executable Statements ..
3076 *
3077 * Test the input parameters.
3078 *
3079  info = 0
3080  IF ( .NOT.lsame( uplo, 'U' ).AND.
3081  $ .NOT.lsame( uplo, 'L' ) )THEN
3082  info = 1
3083  ELSE IF( n.LT.0 )THEN
3084  info = 2
3085  ELSE IF( incx.EQ.0 )THEN
3086  info = 5
3087  ELSE IF( lda.LT.max( 1, n ) )THEN
3088  info = 7
3089  END IF
3090  IF( info.NE.0 )THEN
3091  CALL xerbla( 'CHER ', info )
3092  RETURN
3093  END IF
3094 *
3095 * Quick return if possible.
3096 *
3097  IF( ( n.EQ.0 ).OR.( alpha.EQ.REAL( ZERO ) ) )
3098  $ RETURN
3099 *
3100 * Set the start point in X if the increment is not unity.
3101 *
3102  IF( incx.LE.0 )THEN
3103  kx = 1 - ( n - 1 )*incx
3104  ELSE IF( incx.NE.1 )THEN
3105  kx = 1
3106  END IF
3107 *
3108 * Start the operations. In this version the elements of A are
3109 * accessed sequentially with one pass through the triangular part
3110 * of A.
3111 *
3112  IF( lsame( uplo, 'U' ) )THEN
3113 *
3114 * Form A when A is stored in upper triangle.
3115 *
3116  IF( incx.EQ.1 )THEN
3117  DO 20, j = 1, n
3118  IF( x( j ).NE.zero )THEN
3119  temp = alpha*conjg( x( j ) )
3120  DO 10, i = 1, j - 1
3121  a( i, j ) = a( i, j ) + x( i )*temp
3122  10 CONTINUE
3123  a( j, j ) = REAL( A( J, J ) ) + REAL( x( j )*temp )
3124  ELSE
3125  a( j, j ) = REAL( A( J, J ) )
3126  END IF
3127  20 CONTINUE
3128  ELSE
3129  jx = kx
3130  DO 40, j = 1, n
3131  IF( x( jx ).NE.zero )THEN
3132  temp = alpha*conjg( x( jx ) )
3133  ix = kx
3134  DO 30, i = 1, j - 1
3135  a( i, j ) = a( i, j ) + x( ix )*temp
3136  ix = ix + incx
3137  30 CONTINUE
3138  a( j, j ) = REAL( A( J, J ) ) + REAL( x( jx )*temp )
3139  ELSE
3140  a( j, j ) = REAL( A( J, J ) )
3141  END IF
3142  jx = jx + incx
3143  40 CONTINUE
3144  END IF
3145  ELSE
3146 *
3147 * Form A when A is stored in lower triangle.
3148 *
3149  IF( incx.EQ.1 )THEN
3150  DO 60, j = 1, n
3151  IF( x( j ).NE.zero )THEN
3152  temp = alpha*conjg( x( j ) )
3153  a( j, j ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) )
3154  DO 50, i = j + 1, n
3155  a( i, j ) = a( i, j ) + x( i )*temp
3156  50 CONTINUE
3157  ELSE
3158  a( j, j ) = REAL( A( J, J ) )
3159  END IF
3160  60 CONTINUE
3161  ELSE
3162  jx = kx
3163  DO 80, j = 1, n
3164  IF( x( jx ).NE.zero )THEN
3165  temp = alpha*conjg( x( jx ) )
3166  a( j, j ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) )
3167  ix = jx
3168  DO 70, i = j + 1, n
3169  ix = ix + incx
3170  a( i, j ) = a( i, j ) + x( ix )*temp
3171  70 CONTINUE
3172  ELSE
3173  a( j, j ) = REAL( A( J, J ) )
3174  END IF
3175  jx = jx + incx
3176  80 CONTINUE
3177  END IF
3178  END IF
3179 *
3180  RETURN
3181 *
3182 * End of CHER .
3183 *
3184  END
3185  SUBROUTINE cherk ( UPLO, TRANS, N, K, ALPHA, A, LDA,
3186  $ beta, c, ldc )
3187 * .. Scalar Arguments ..
3188  CHARACTER*1 UPLO, TRANS
3189  INTEGER N, K, LDA, LDC
3190  REAL ALPHA, BETA
3191 * .. Array Arguments ..
3192  COMPLEX A( lda, * ), C( ldc, * )
3193 * ..
3194 *
3195 * Purpose
3196 * =======
3197 *
3198 * CHERK performs one of the hermitian rank k operations
3199 *
3200 * C := alpha*A*conjg( A' ) + beta*C,
3201 *
3202 * or
3203 *
3204 * C := alpha*conjg( A' )*A + beta*C,
3205 *
3206 * where alpha and beta are real scalars, C is an n by n hermitian
3207 * matrix and A is an n by k matrix in the first case and a k by n
3208 * matrix in the second case.
3209 *
3210 * Parameters
3211 * ==========
3212 *
3213 * UPLO - CHARACTER*1.
3214 * On entry, UPLO specifies whether the upper or lower
3215 * triangular part of the array C is to be referenced as
3216 * follows:
3217 *
3218 * UPLO = 'U' or 'u' Only the upper triangular part of C
3219 * is to be referenced.
3220 *
3221 * UPLO = 'L' or 'l' Only the lower triangular part of C
3222 * is to be referenced.
3223 *
3224 * Unchanged on exit.
3225 *
3226 * TRANS - CHARACTER*1.
3227 * On entry, TRANS specifies the operation to be performed as
3228 * follows:
3229 *
3230 * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.
3231 *
3232 * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.
3233 *
3234 * Unchanged on exit.
3235 *
3236 * N - INTEGER.
3237 * On entry, N specifies the order of the matrix C. N must be
3238 * at least zero.
3239 * Unchanged on exit.
3240 *
3241 * K - INTEGER.
3242 * On entry with TRANS = 'N' or 'n', K specifies the number
3243 * of columns of the matrix A, and on entry with
3244 * TRANS = 'C' or 'c', K specifies the number of rows of the
3245 * matrix A. K must be at least zero.
3246 * Unchanged on exit.
3247 *
3248 * ALPHA - REAL .
3249 * On entry, ALPHA specifies the scalar alpha.
3250 * Unchanged on exit.
3251 *
3252 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
3253 * k when TRANS = 'N' or 'n', and is n otherwise.
3254 * Before entry with TRANS = 'N' or 'n', the leading n by k
3255 * part of the array A must contain the matrix A, otherwise
3256 * the leading k by n part of the array A must contain the
3257 * matrix A.
3258 * Unchanged on exit.
3259 *
3260 * LDA - INTEGER.
3261 * On entry, LDA specifies the first dimension of A as declared
3262 * in the calling (sub) program. When TRANS = 'N' or 'n'
3263 * then LDA must be at least max( 1, n ), otherwise LDA must
3264 * be at least max( 1, k ).
3265 * Unchanged on exit.
3266 *
3267 * BETA - REAL .
3268 * On entry, BETA specifies the scalar beta.
3269 * Unchanged on exit.
3270 *
3271 * C - COMPLEX array of DIMENSION ( LDC, n ).
3272 * Before entry with UPLO = 'U' or 'u', the leading n by n
3273 * upper triangular part of the array C must contain the upper
3274 * triangular part of the hermitian matrix and the strictly
3275 * lower triangular part of C is not referenced. On exit, the
3276 * upper triangular part of the array C is overwritten by the
3277 * upper triangular part of the updated matrix.
3278 * Before entry with UPLO = 'L' or 'l', the leading n by n
3279 * lower triangular part of the array C must contain the lower
3280 * triangular part of the hermitian matrix and the strictly
3281 * upper triangular part of C is not referenced. On exit, the
3282 * lower triangular part of the array C is overwritten by the
3283 * lower triangular part of the updated matrix.
3284 * Note that the imaginary parts of the diagonal elements need
3285 * not be set, they are assumed to be zero, and on exit they
3286 * are set to zero.
3287 *
3288 * LDC - INTEGER.
3289 * On entry, LDC specifies the first dimension of C as declared
3290 * in the calling (sub) program. LDC must be at least
3291 * max( 1, n ).
3292 * Unchanged on exit.
3293 *
3294 *
3295 * Level 3 Blas routine.
3296 *
3297 * -- Written on 8-February-1989.
3298 * Jack Dongarra, Argonne National Laboratory.
3299 * Iain Duff, AERE Harwell.
3300 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3301 * Sven Hammarling, Numerical Algorithms Group Ltd.
3302 *
3303 * -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
3304 * Ed Anderson, Cray Research Inc.
3305 *
3306 *
3307 * .. External Functions ..
3308  LOGICAL LSAME
3309  EXTERNAL lsame
3310 * .. External Subroutines ..
3311  EXTERNAL xerbla
3312 * .. Intrinsic Functions ..
3313  INTRINSIC cmplx, conjg, max, real
3314 * .. Local Scalars ..
3315  LOGICAL UPPER
3316  INTEGER I, INFO, J, L, NROWA
3317  REAL RTEMP
3318  COMPLEX TEMP
3319 * .. Parameters ..
3320  REAL ONE , ZERO
3321  parameter( one = 1.0e+0, zero = 0.0e+0 )
3322 * ..
3323 * .. Executable Statements ..
3324 *
3325 * Test the input parameters.
3326 *
3327  IF( lsame( trans, 'N' ) )THEN
3328  nrowa = n
3329  ELSE
3330  nrowa = k
3331  END IF
3332  upper = lsame( uplo, 'U' )
3333 *
3334  info = 0
3335  IF( ( .NOT.upper ).AND.
3336  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
3337  info = 1
3338  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
3339  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
3340  info = 2
3341  ELSE IF( n .LT.0 )THEN
3342  info = 3
3343  ELSE IF( k .LT.0 )THEN
3344  info = 4
3345  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
3346  info = 7
3347  ELSE IF( ldc.LT.max( 1, n ) )THEN
3348  info = 10
3349  END IF
3350  IF( info.NE.0 )THEN
3351  CALL xerbla( 'CHERK ', info )
3352  RETURN
3353  END IF
3354 *
3355 * Quick return if possible.
3356 *
3357  IF( ( n.EQ.0 ).OR.
3358  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
3359  $ RETURN
3360 *
3361 * And when alpha.eq.zero.
3362 *
3363  IF( alpha.EQ.zero )THEN
3364  IF( upper )THEN
3365  IF( beta.EQ.zero )THEN
3366  DO 20, j = 1, n
3367  DO 10, i = 1, j
3368  c( i, j ) = zero
3369  10 CONTINUE
3370  20 CONTINUE
3371  ELSE
3372  DO 40, j = 1, n
3373  DO 30, i = 1, j - 1
3374  c( i, j ) = beta*c( i, j )
3375  30 CONTINUE
3376  c( j, j ) = beta*REAL( C( J, J ) )
3377  40 CONTINUE
3378  END IF
3379  ELSE
3380  IF( beta.EQ.zero )THEN
3381  DO 60, j = 1, n
3382  DO 50, i = j, n
3383  c( i, j ) = zero
3384  50 CONTINUE
3385  60 CONTINUE
3386  ELSE
3387  DO 80, j = 1, n
3388  c( j, j ) = beta*REAL( C( J, J ) )
3389  DO 70, i = j + 1, n
3390  c( i, j ) = beta*c( i, j )
3391  70 CONTINUE
3392  80 CONTINUE
3393  END IF
3394  END IF
3395  RETURN
3396  END IF
3397 *
3398 * Start the operations.
3399 *
3400  IF( lsame( trans, 'N' ) )THEN
3401 *
3402 * Form C := alpha*A*conjg( A' ) + beta*C.
3403 *
3404  IF( upper )THEN
3405  DO 130, j = 1, n
3406  IF( beta.EQ.zero )THEN
3407  DO 90, i = 1, j
3408  c( i, j ) = zero
3409  90 CONTINUE
3410  ELSE IF( beta.NE.one )THEN
3411  DO 100, i = 1, j - 1
3412  c( i, j ) = beta*c( i, j )
3413  100 CONTINUE
3414  c( j, j ) = beta*REAL( C( J, J ) )
3415  ELSE
3416  c( j, j ) = REAL( C( J, J ) )
3417  END IF
3418  DO 120, l = 1, k
3419  IF( a( j, l ).NE.cmplx( zero ) )THEN
3420  temp = alpha*conjg( a( j, l ) )
3421  DO 110, i = 1, j - 1
3422  c( i, j ) = c( i, j ) + temp*a( i, l )
3423  110 CONTINUE
3424  c( j, j ) = REAL( C( J, J ) ) +
3425  $ REAL( TEMP*A( I, L ) )
3426  END IF
3427  120 CONTINUE
3428  130 CONTINUE
3429  ELSE
3430  DO 180, j = 1, n
3431  IF( beta.EQ.zero )THEN
3432  DO 140, i = j, n
3433  c( i, j ) = zero
3434  140 CONTINUE
3435  ELSE IF( beta.NE.one )THEN
3436  c( j, j ) = beta*REAL( C( J, J ) )
3437  DO 150, i = j + 1, n
3438  c( i, j ) = beta*c( i, j )
3439  150 CONTINUE
3440  ELSE
3441  c( j, j ) = REAL( C( J, J ) )
3442  END IF
3443  DO 170, l = 1, k
3444  IF( a( j, l ).NE.cmplx( zero ) )THEN
3445  temp = alpha*conjg( a( j, l ) )
3446  c( j, j ) = REAL( C( J, J ) ) +
3447  $ REAL( TEMP*A( J, L ) )
3448  DO 160, i = j + 1, n
3449  c( i, j ) = c( i, j ) + temp*a( i, l )
3450  160 CONTINUE
3451  END IF
3452  170 CONTINUE
3453  180 CONTINUE
3454  END IF
3455  ELSE
3456 *
3457 * Form C := alpha*conjg( A' )*A + beta*C.
3458 *
3459  IF( upper )THEN
3460  DO 220, j = 1, n
3461  DO 200, i = 1, j - 1
3462  temp = zero
3463  DO 190, l = 1, k
3464  temp = temp + conjg( a( l, i ) )*a( l, j )
3465  190 CONTINUE
3466  IF( beta.EQ.zero )THEN
3467  c( i, j ) = alpha*temp
3468  ELSE
3469  c( i, j ) = alpha*temp + beta*c( i, j )
3470  END IF
3471  200 CONTINUE
3472  rtemp = zero
3473  DO 210, l = 1, k
3474  rtemp = rtemp + conjg( a( l, j ) )*a( l, j )
3475  210 CONTINUE
3476  IF( beta.EQ.zero )THEN
3477  c( j, j ) = alpha*rtemp
3478  ELSE
3479  c( j, j ) = alpha*rtemp + beta*REAL( C( J, J ) )
3480  END IF
3481  220 CONTINUE
3482  ELSE
3483  DO 260, j = 1, n
3484  rtemp = zero
3485  DO 230, l = 1, k
3486  rtemp = rtemp + conjg( a( l, j ) )*a( l, j )
3487  230 CONTINUE
3488  IF( beta.EQ.zero )THEN
3489  c( j, j ) = alpha*rtemp
3490  ELSE
3491  c( j, j ) = alpha*rtemp + beta*REAL( C( J, J ) )
3492  END IF
3493  DO 250, i = j + 1, n
3494  temp = zero
3495  DO 240, l = 1, k
3496  temp = temp + conjg( a( l, i ) )*a( l, j )
3497  240 CONTINUE
3498  IF( beta.EQ.zero )THEN
3499  c( i, j ) = alpha*temp
3500  ELSE
3501  c( i, j ) = alpha*temp + beta*c( i, j )
3502  END IF
3503  250 CONTINUE
3504  260 CONTINUE
3505  END IF
3506  END IF
3507 *
3508  RETURN
3509 *
3510 * End of CHERK .
3511 *
3512  END
3513  SUBROUTINE chpmv ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
3514 * .. Scalar Arguments ..
3515  COMPLEX ALPHA, BETA
3516  INTEGER INCX, INCY, N
3517  CHARACTER*1 UPLO
3518 * .. Array Arguments ..
3519  COMPLEX AP( * ), X( * ), Y( * )
3520 * ..
3521 *
3522 * Purpose
3523 * =======
3524 *
3525 * CHPMV performs the matrix-vector operation
3526 *
3527 * y := alpha*A*x + beta*y,
3528 *
3529 * where alpha and beta are scalars, x and y are n element vectors and
3530 * A is an n by n hermitian matrix, supplied in packed form.
3531 *
3532 * Parameters
3533 * ==========
3534 *
3535 * UPLO - CHARACTER*1.
3536 * On entry, UPLO specifies whether the upper or lower
3537 * triangular part of the matrix A is supplied in the packed
3538 * array AP as follows:
3539 *
3540 * UPLO = 'U' or 'u' The upper triangular part of A is
3541 * supplied in AP.
3542 *
3543 * UPLO = 'L' or 'l' The lower triangular part of A is
3544 * supplied in AP.
3545 *
3546 * Unchanged on exit.
3547 *
3548 * N - INTEGER.
3549 * On entry, N specifies the order of the matrix A.
3550 * N must be at least zero.
3551 * Unchanged on exit.
3552 *
3553 * ALPHA - COMPLEX .
3554 * On entry, ALPHA specifies the scalar alpha.
3555 * Unchanged on exit.
3556 *
3557 * AP - COMPLEX array of DIMENSION at least
3558 * ( ( n*( n + 1 ) )/2 ).
3559 * Before entry with UPLO = 'U' or 'u', the array AP must
3560 * contain the upper triangular part of the hermitian matrix
3561 * packed sequentially, column by column, so that AP( 1 )
3562 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
3563 * and a( 2, 2 ) respectively, and so on.
3564 * Before entry with UPLO = 'L' or 'l', the array AP must
3565 * contain the lower triangular part of the hermitian matrix
3566 * packed sequentially, column by column, so that AP( 1 )
3567 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
3568 * and a( 3, 1 ) respectively, and so on.
3569 * Note that the imaginary parts of the diagonal elements need
3570 * not be set and are assumed to be zero.
3571 * Unchanged on exit.
3572 *
3573 * X - COMPLEX array of dimension at least
3574 * ( 1 + ( n - 1 )*abs( INCX ) ).
3575 * Before entry, the incremented array X must contain the n
3576 * element vector x.
3577 * Unchanged on exit.
3578 *
3579 * INCX - INTEGER.
3580 * On entry, INCX specifies the increment for the elements of
3581 * X. INCX must not be zero.
3582 * Unchanged on exit.
3583 *
3584 * BETA - COMPLEX .
3585 * On entry, BETA specifies the scalar beta. When BETA is
3586 * supplied as zero then Y need not be set on input.
3587 * Unchanged on exit.
3588 *
3589 * Y - COMPLEX array of dimension at least
3590 * ( 1 + ( n - 1 )*abs( INCY ) ).
3591 * Before entry, the incremented array Y must contain the n
3592 * element vector y. On exit, Y is overwritten by the updated
3593 * vector y.
3594 *
3595 * INCY - INTEGER.
3596 * On entry, INCY specifies the increment for the elements of
3597 * Y. INCY must not be zero.
3598 * Unchanged on exit.
3599 *
3600 *
3601 * Level 2 Blas routine.
3602 *
3603 * -- Written on 22-October-1986.
3604 * Jack Dongarra, Argonne National Lab.
3605 * Jeremy Du Croz, Nag Central Office.
3606 * Sven Hammarling, Nag Central Office.
3607 * Richard Hanson, Sandia National Labs.
3608 *
3609 *
3610 * .. Parameters ..
3611  COMPLEX ONE
3612  parameter( one = ( 1.0e+0, 0.0e+0 ) )
3613  COMPLEX ZERO
3614  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
3615 * .. Local Scalars ..
3616  COMPLEX TEMP1, TEMP2
3617  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
3618 * .. External Functions ..
3619  LOGICAL LSAME
3620  EXTERNAL lsame
3621 * .. External Subroutines ..
3622  EXTERNAL xerbla
3623 * .. Intrinsic Functions ..
3624  INTRINSIC conjg, real
3625 * ..
3626 * .. Executable Statements ..
3627 *
3628 * Test the input parameters.
3629 *
3630  info = 0
3631  IF ( .NOT.lsame( uplo, 'U' ).AND.
3632  $ .NOT.lsame( uplo, 'L' ) )THEN
3633  info = 1
3634  ELSE IF( n.LT.0 )THEN
3635  info = 2
3636  ELSE IF( incx.EQ.0 )THEN
3637  info = 6
3638  ELSE IF( incy.EQ.0 )THEN
3639  info = 9
3640  END IF
3641  IF( info.NE.0 )THEN
3642  CALL xerbla( 'CHPMV ', info )
3643  RETURN
3644  END IF
3645 *
3646 * Quick return if possible.
3647 *
3648  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
3649  $ RETURN
3650 *
3651 * Set up the start points in X and Y.
3652 *
3653  IF( incx.GT.0 )THEN
3654  kx = 1
3655  ELSE
3656  kx = 1 - ( n - 1 )*incx
3657  END IF
3658  IF( incy.GT.0 )THEN
3659  ky = 1
3660  ELSE
3661  ky = 1 - ( n - 1 )*incy
3662  END IF
3663 *
3664 * Start the operations. In this version the elements of the array AP
3665 * are accessed sequentially with one pass through AP.
3666 *
3667 * First form y := beta*y.
3668 *
3669  IF( beta.NE.one )THEN
3670  IF( incy.EQ.1 )THEN
3671  IF( beta.EQ.zero )THEN
3672  DO 10, i = 1, n
3673  y( i ) = zero
3674  10 CONTINUE
3675  ELSE
3676  DO 20, i = 1, n
3677  y( i ) = beta*y( i )
3678  20 CONTINUE
3679  END IF
3680  ELSE
3681  iy = ky
3682  IF( beta.EQ.zero )THEN
3683  DO 30, i = 1, n
3684  y( iy ) = zero
3685  iy = iy + incy
3686  30 CONTINUE
3687  ELSE
3688  DO 40, i = 1, n
3689  y( iy ) = beta*y( iy )
3690  iy = iy + incy
3691  40 CONTINUE
3692  END IF
3693  END IF
3694  END IF
3695  IF( alpha.EQ.zero )
3696  $ RETURN
3697  kk = 1
3698  IF( lsame( uplo, 'U' ) )THEN
3699 *
3700 * Form y when AP contains the upper triangle.
3701 *
3702  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
3703  DO 60, j = 1, n
3704  temp1 = alpha*x( j )
3705  temp2 = zero
3706  k = kk
3707  DO 50, i = 1, j - 1
3708  y( i ) = y( i ) + temp1*ap( k )
3709  temp2 = temp2 + conjg( ap( k ) )*x( i )
3710  k = k + 1
3711  50 CONTINUE
3712  y( j ) = y( j ) + temp1*REAL( AP( KK + J - 1 ) )
3713  $ + alpha*temp2
3714  kk = kk + j
3715  60 CONTINUE
3716  ELSE
3717  jx = kx
3718  jy = ky
3719  DO 80, j = 1, n
3720  temp1 = alpha*x( jx )
3721  temp2 = zero
3722  ix = kx
3723  iy = ky
3724  DO 70, k = kk, kk + j - 2
3725  y( iy ) = y( iy ) + temp1*ap( k )
3726  temp2 = temp2 + conjg( ap( k ) )*x( ix )
3727  ix = ix + incx
3728  iy = iy + incy
3729  70 CONTINUE
3730  y( jy ) = y( jy ) + temp1*REAL( AP( KK + J - 1 ) )
3731  $ + alpha*temp2
3732  jx = jx + incx
3733  jy = jy + incy
3734  kk = kk + j
3735  80 CONTINUE
3736  END IF
3737  ELSE
3738 *
3739 * Form y when AP contains the lower triangle.
3740 *
3741  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
3742  DO 100, j = 1, n
3743  temp1 = alpha*x( j )
3744  temp2 = zero
3745  y( j ) = y( j ) + temp1*REAL( AP( KK ) )
3746  k = kk + 1
3747  DO 90, i = j + 1, n
3748  y( i ) = y( i ) + temp1*ap( k )
3749  temp2 = temp2 + conjg( ap( k ) )*x( i )
3750  k = k + 1
3751  90 CONTINUE
3752  y( j ) = y( j ) + alpha*temp2
3753  kk = kk + ( n - j + 1 )
3754  100 CONTINUE
3755  ELSE
3756  jx = kx
3757  jy = ky
3758  DO 120, j = 1, n
3759  temp1 = alpha*x( jx )
3760  temp2 = zero
3761  y( jy ) = y( jy ) + temp1*REAL( AP( KK ) )
3762  ix = jx
3763  iy = jy
3764  DO 110, k = kk + 1, kk + n - j
3765  ix = ix + incx
3766  iy = iy + incy
3767  y( iy ) = y( iy ) + temp1*ap( k )
3768  temp2 = temp2 + conjg( ap( k ) )*x( ix )
3769  110 CONTINUE
3770  y( jy ) = y( jy ) + alpha*temp2
3771  jx = jx + incx
3772  jy = jy + incy
3773  kk = kk + ( n - j + 1 )
3774  120 CONTINUE
3775  END IF
3776  END IF
3777 *
3778  RETURN
3779 *
3780 * End of CHPMV .
3781 *
3782  END
3783  SUBROUTINE chpr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
3784 * .. Scalar Arguments ..
3785  COMPLEX ALPHA
3786  INTEGER INCX, INCY, N
3787  CHARACTER*1 UPLO
3788 * .. Array Arguments ..
3789  COMPLEX AP( * ), X( * ), Y( * )
3790 * ..
3791 *
3792 * Purpose
3793 * =======
3794 *
3795 * CHPR2 performs the hermitian rank 2 operation
3796 *
3797 * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
3798 *
3799 * where alpha is a scalar, x and y are n element vectors and A is an
3800 * n by n hermitian matrix, supplied in packed form.
3801 *
3802 * Parameters
3803 * ==========
3804 *
3805 * UPLO - CHARACTER*1.
3806 * On entry, UPLO specifies whether the upper or lower
3807 * triangular part of the matrix A is supplied in the packed
3808 * array AP as follows:
3809 *
3810 * UPLO = 'U' or 'u' The upper triangular part of A is
3811 * supplied in AP.
3812 *
3813 * UPLO = 'L' or 'l' The lower triangular part of A is
3814 * supplied in AP.
3815 *
3816 * Unchanged on exit.
3817 *
3818 * N - INTEGER.
3819 * On entry, N specifies the order of the matrix A.
3820 * N must be at least zero.
3821 * Unchanged on exit.
3822 *
3823 * ALPHA - COMPLEX .
3824 * On entry, ALPHA specifies the scalar alpha.
3825 * Unchanged on exit.
3826 *
3827 * X - COMPLEX array of dimension at least
3828 * ( 1 + ( n - 1 )*abs( INCX ) ).
3829 * Before entry, the incremented array X must contain the n
3830 * element vector x.
3831 * Unchanged on exit.
3832 *
3833 * INCX - INTEGER.
3834 * On entry, INCX specifies the increment for the elements of
3835 * X. INCX must not be zero.
3836 * Unchanged on exit.
3837 *
3838 * Y - COMPLEX array of dimension at least
3839 * ( 1 + ( n - 1 )*abs( INCY ) ).
3840 * Before entry, the incremented array Y must contain the n
3841 * element vector y.
3842 * Unchanged on exit.
3843 *
3844 * INCY - INTEGER.
3845 * On entry, INCY specifies the increment for the elements of
3846 * Y. INCY must not be zero.
3847 * Unchanged on exit.
3848 *
3849 * AP - COMPLEX array of DIMENSION at least
3850 * ( ( n*( n + 1 ) )/2 ).
3851 * Before entry with UPLO = 'U' or 'u', the array AP must
3852 * contain the upper triangular part of the hermitian matrix
3853 * packed sequentially, column by column, so that AP( 1 )
3854 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
3855 * and a( 2, 2 ) respectively, and so on. On exit, the array
3856 * AP is overwritten by the upper triangular part of the
3857 * updated matrix.
3858 * Before entry with UPLO = 'L' or 'l', the array AP must
3859 * contain the lower triangular part of the hermitian matrix
3860 * packed sequentially, column by column, so that AP( 1 )
3861 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
3862 * and a( 3, 1 ) respectively, and so on. On exit, the array
3863 * AP is overwritten by the lower triangular part of the
3864 * updated matrix.
3865 * Note that the imaginary parts of the diagonal elements need
3866 * not be set, they are assumed to be zero, and on exit they
3867 * are set to zero.
3868 *
3869 *
3870 * Level 2 Blas routine.
3871 *
3872 * -- Written on 22-October-1986.
3873 * Jack Dongarra, Argonne National Lab.
3874 * Jeremy Du Croz, Nag Central Office.
3875 * Sven Hammarling, Nag Central Office.
3876 * Richard Hanson, Sandia National Labs.
3877 *
3878 *
3879 * .. Parameters ..
3880  COMPLEX ZERO
3881  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
3882 * .. Local Scalars ..
3883  COMPLEX TEMP1, TEMP2
3884  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
3885 * .. External Functions ..
3886  LOGICAL LSAME
3887  EXTERNAL lsame
3888 * .. External Subroutines ..
3889  EXTERNAL xerbla
3890 * .. Intrinsic Functions ..
3891  INTRINSIC conjg, real
3892 * ..
3893 * .. Executable Statements ..
3894 *
3895 * Test the input parameters.
3896 *
3897  info = 0
3898  IF ( .NOT.lsame( uplo, 'U' ).AND.
3899  $ .NOT.lsame( uplo, 'L' ) )THEN
3900  info = 1
3901  ELSE IF( n.LT.0 )THEN
3902  info = 2
3903  ELSE IF( incx.EQ.0 )THEN
3904  info = 5
3905  ELSE IF( incy.EQ.0 )THEN
3906  info = 7
3907  END IF
3908  IF( info.NE.0 )THEN
3909  CALL xerbla( 'CHPR2 ', info )
3910  RETURN
3911  END IF
3912 *
3913 * Quick return if possible.
3914 *
3915  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
3916  $ RETURN
3917 *
3918 * Set up the start points in X and Y if the increments are not both
3919 * unity.
3920 *
3921  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
3922  IF( incx.GT.0 )THEN
3923  kx = 1
3924  ELSE
3925  kx = 1 - ( n - 1 )*incx
3926  END IF
3927  IF( incy.GT.0 )THEN
3928  ky = 1
3929  ELSE
3930  ky = 1 - ( n - 1 )*incy
3931  END IF
3932  jx = kx
3933  jy = ky
3934  END IF
3935 *
3936 * Start the operations. In this version the elements of the array AP
3937 * are accessed sequentially with one pass through AP.
3938 *
3939  kk = 1
3940  IF( lsame( uplo, 'U' ) )THEN
3941 *
3942 * Form A when upper triangle is stored in AP.
3943 *
3944  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
3945  DO 20, j = 1, n
3946  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
3947  temp1 = alpha*conjg( y( j ) )
3948  temp2 = conjg( alpha*x( j ) )
3949  k = kk
3950  DO 10, i = 1, j - 1
3951  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
3952  k = k + 1
3953  10 CONTINUE
3954  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) ) +
3955  $ REAL( x( j )*temp1 + y( j )*temp2 )
3956  ELSE
3957  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
3958  END IF
3959  kk = kk + j
3960  20 CONTINUE
3961  ELSE
3962  DO 40, j = 1, n
3963  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
3964  temp1 = alpha*conjg( y( jy ) )
3965  temp2 = conjg( alpha*x( jx ) )
3966  ix = kx
3967  iy = ky
3968  DO 30, k = kk, kk + j - 2
3969  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
3970  ix = ix + incx
3971  iy = iy + incy
3972  30 CONTINUE
3973  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) ) +
3974  $ REAL( x( jx )*temp1 +
3975  $ y( jy )*temp2 )
3976  ELSE
3977  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
3978  END IF
3979  jx = jx + incx
3980  jy = jy + incy
3981  kk = kk + j
3982  40 CONTINUE
3983  END IF
3984  ELSE
3985 *
3986 * Form A when lower triangle is stored in AP.
3987 *
3988  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
3989  DO 60, j = 1, n
3990  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
3991  temp1 = alpha*conjg( y( j ) )
3992  temp2 = conjg( alpha*x( j ) )
3993  ap( kk ) = REAL( AP( KK ) ) +
3994  $ REAL( x( j )*temp1 + y( j )*temp2 )
3995  k = kk + 1
3996  DO 50, i = j + 1, n
3997  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
3998  k = k + 1
3999  50 CONTINUE
4000  ELSE
4001  ap( kk ) = REAL( AP( KK ) )
4002  END IF
4003  kk = kk + n - j + 1
4004  60 CONTINUE
4005  ELSE
4006  DO 80, j = 1, n
4007  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
4008  temp1 = alpha*conjg( y( jy ) )
4009  temp2 = conjg( alpha*x( jx ) )
4010  ap( kk ) = REAL( AP( KK ) ) +
4011  $ REAL( x( jx )*temp1 + y( jy )*temp2 )
4012  ix = jx
4013  iy = jy
4014  DO 70, k = kk + 1, kk + n - j
4015  ix = ix + incx
4016  iy = iy + incy
4017  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
4018  70 CONTINUE
4019  ELSE
4020  ap( kk ) = REAL( AP( KK ) )
4021  END IF
4022  jx = jx + incx
4023  jy = jy + incy
4024  kk = kk + n - j + 1
4025  80 CONTINUE
4026  END IF
4027  END IF
4028 *
4029  RETURN
4030 *
4031 * End of CHPR2 .
4032 *
4033  END
4034  SUBROUTINE chpr ( UPLO, N, ALPHA, X, INCX, AP )
4035 * .. Scalar Arguments ..
4036  REAL ALPHA
4037  INTEGER INCX, N
4038  CHARACTER*1 UPLO
4039 * .. Array Arguments ..
4040  COMPLEX AP( * ), X( * )
4041 * ..
4042 *
4043 * Purpose
4044 * =======
4045 *
4046 * CHPR performs the hermitian rank 1 operation
4047 *
4048 * A := alpha*x*conjg( x' ) + A,
4049 *
4050 * where alpha is a real scalar, x is an n element vector and A is an
4051 * n by n hermitian matrix, supplied in packed form.
4052 *
4053 * Parameters
4054 * ==========
4055 *
4056 * UPLO - CHARACTER*1.
4057 * On entry, UPLO specifies whether the upper or lower
4058 * triangular part of the matrix A is supplied in the packed
4059 * array AP as follows:
4060 *
4061 * UPLO = 'U' or 'u' The upper triangular part of A is
4062 * supplied in AP.
4063 *
4064 * UPLO = 'L' or 'l' The lower triangular part of A is
4065 * supplied in AP.
4066 *
4067 * Unchanged on exit.
4068 *
4069 * N - INTEGER.
4070 * On entry, N specifies the order of the matrix A.
4071 * N must be at least zero.
4072 * Unchanged on exit.
4073 *
4074 * ALPHA - REAL .
4075 * On entry, ALPHA specifies the scalar alpha.
4076 * Unchanged on exit.
4077 *
4078 * X - COMPLEX array of dimension at least
4079 * ( 1 + ( n - 1 )*abs( INCX ) ).
4080 * Before entry, the incremented array X must contain the n
4081 * element vector x.
4082 * Unchanged on exit.
4083 *
4084 * INCX - INTEGER.
4085 * On entry, INCX specifies the increment for the elements of
4086 * X. INCX must not be zero.
4087 * Unchanged on exit.
4088 *
4089 * AP - COMPLEX array of DIMENSION at least
4090 * ( ( n*( n + 1 ) )/2 ).
4091 * Before entry with UPLO = 'U' or 'u', the array AP must
4092 * contain the upper triangular part of the hermitian matrix
4093 * packed sequentially, column by column, so that AP( 1 )
4094 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
4095 * and a( 2, 2 ) respectively, and so on. On exit, the array
4096 * AP is overwritten by the upper triangular part of the
4097 * updated matrix.
4098 * Before entry with UPLO = 'L' or 'l', the array AP must
4099 * contain the lower triangular part of the hermitian matrix
4100 * packed sequentially, column by column, so that AP( 1 )
4101 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
4102 * and a( 3, 1 ) respectively, and so on. On exit, the array
4103 * AP is overwritten by the lower triangular part of the
4104 * updated matrix.
4105 * Note that the imaginary parts of the diagonal elements need
4106 * not be set, they are assumed to be zero, and on exit they
4107 * are set to zero.
4108 *
4109 *
4110 * Level 2 Blas routine.
4111 *
4112 * -- Written on 22-October-1986.
4113 * Jack Dongarra, Argonne National Lab.
4114 * Jeremy Du Croz, Nag Central Office.
4115 * Sven Hammarling, Nag Central Office.
4116 * Richard Hanson, Sandia National Labs.
4117 *
4118 *
4119 * .. Parameters ..
4120  COMPLEX ZERO
4121  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
4122 * .. Local Scalars ..
4123  COMPLEX TEMP
4124  INTEGER I, INFO, IX, J, JX, K, KK, KX
4125 * .. External Functions ..
4126  LOGICAL LSAME
4127  EXTERNAL lsame
4128 * .. External Subroutines ..
4129  EXTERNAL xerbla
4130 * .. Intrinsic Functions ..
4131  INTRINSIC conjg, real
4132 * ..
4133 * .. Executable Statements ..
4134 *
4135 * Test the input parameters.
4136 *
4137  info = 0
4138  IF ( .NOT.lsame( uplo, 'U' ).AND.
4139  $ .NOT.lsame( uplo, 'L' ) )THEN
4140  info = 1
4141  ELSE IF( n.LT.0 )THEN
4142  info = 2
4143  ELSE IF( incx.EQ.0 )THEN
4144  info = 5
4145  END IF
4146  IF( info.NE.0 )THEN
4147  CALL xerbla( 'CHPR ', info )
4148  RETURN
4149  END IF
4150 *
4151 * Quick return if possible.
4152 *
4153  IF( ( n.EQ.0 ).OR.( alpha.EQ.REAL( ZERO ) ) )
4154  $ RETURN
4155 *
4156 * Set the start point in X if the increment is not unity.
4157 *
4158  IF( incx.LE.0 )THEN
4159  kx = 1 - ( n - 1 )*incx
4160  ELSE IF( incx.NE.1 )THEN
4161  kx = 1
4162  END IF
4163 *
4164 * Start the operations. In this version the elements of the array AP
4165 * are accessed sequentially with one pass through AP.
4166 *
4167  kk = 1
4168  IF( lsame( uplo, 'U' ) )THEN
4169 *
4170 * Form A when upper triangle is stored in AP.
4171 *
4172  IF( incx.EQ.1 )THEN
4173  DO 20, j = 1, n
4174  IF( x( j ).NE.zero )THEN
4175  temp = alpha*conjg( x( j ) )
4176  k = kk
4177  DO 10, i = 1, j - 1
4178  ap( k ) = ap( k ) + x( i )*temp
4179  k = k + 1
4180  10 CONTINUE
4181  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
4182  $ + REAL( x( j )*temp )
4183  ELSE
4184  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
4185  END IF
4186  kk = kk + j
4187  20 CONTINUE
4188  ELSE
4189  jx = kx
4190  DO 40, j = 1, n
4191  IF( x( jx ).NE.zero )THEN
4192  temp = alpha*conjg( x( jx ) )
4193  ix = kx
4194  DO 30, k = kk, kk + j - 2
4195  ap( k ) = ap( k ) + x( ix )*temp
4196  ix = ix + incx
4197  30 CONTINUE
4198  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
4199  $ + REAL( x( jx )*temp )
4200  ELSE
4201  ap( kk + j - 1 ) = REAL( AP( KK + J - 1 ) )
4202  END IF
4203  jx = jx + incx
4204  kk = kk + j
4205  40 CONTINUE
4206  END IF
4207  ELSE
4208 *
4209 * Form A when lower triangle is stored in AP.
4210 *
4211  IF( incx.EQ.1 )THEN
4212  DO 60, j = 1, n
4213  IF( x( j ).NE.zero )THEN
4214  temp = alpha*conjg( x( j ) )
4215  ap( kk ) = REAL( AP( KK ) ) + REAL( TEMP*X( J ) )
4216  k = kk + 1
4217  DO 50, i = j + 1, n
4218  ap( k ) = ap( k ) + x( i )*temp
4219  k = k + 1
4220  50 CONTINUE
4221  ELSE
4222  ap( kk ) = REAL( AP( KK ) )
4223  END IF
4224  kk = kk + n - j + 1
4225  60 CONTINUE
4226  ELSE
4227  jx = kx
4228  DO 80, j = 1, n
4229  IF( x( jx ).NE.zero )THEN
4230  temp = alpha*conjg( x( jx ) )
4231  ap( kk ) = REAL( AP( KK ) ) + REAL( TEMP*X( JX ) )
4232  ix = jx
4233  DO 70, k = kk + 1, kk + n - j
4234  ix = ix + incx
4235  ap( k ) = ap( k ) + x( ix )*temp
4236  70 CONTINUE
4237  ELSE
4238  ap( kk ) = REAL( AP( KK ) )
4239  END IF
4240  jx = jx + incx
4241  kk = kk + n - j + 1
4242  80 CONTINUE
4243  END IF
4244  END IF
4245 *
4246  RETURN
4247 *
4248 * End of CHPR .
4249 *
4250  END
4251  subroutine crotg(ca,cb,c,s)
4252  complex ca,cb,s
4253  real c
4254  real norm,scale
4255  complex alpha
4256  if (cabs(ca) .ne. 0.) go to 10
4257  c = 0.
4258  s = (1.,0.)
4259  ca = cb
4260  go to 20
4261  10 continue
4262  scale = cabs(ca) + cabs(cb)
4263  norm = scale * sqrt((cabs(ca/scale))**2 + (cabs(cb/scale))**2)
4264  alpha = ca /cabs(ca)
4265  c = cabs(ca) / norm
4266  s = alpha * conjg(cb) / norm
4267  ca = alpha * norm
4268  20 continue
4269  return
4270  end
4271  subroutine cscal(n,ca,cx,incx)
4272 c
4273 c scales a vector by a constant.
4274 c jack dongarra, linpack, 3/11/78.
4275 c modified 3/93 to return if incx .le. 0.
4276 c modified 12/3/93, array(1) declarations changed to array(*)
4277 c
4278  complex ca,cx(*)
4279  integer i,incx,n,nincx
4280 c
4281  if( n.le.0 .or. incx.le.0 )return
4282  if(incx.eq.1)go to 20
4283 c
4284 c code for increment not equal to 1
4285 c
4286  nincx = n*incx
4287  do 10 i = 1,nincx,incx
4288  cx(i) = ca*cx(i)
4289  10 continue
4290  return
4291 c
4292 c code for increment equal to 1
4293 c
4294  20 do 30 i = 1,n
4295  cx(i) = ca*cx(i)
4296  30 continue
4297  return
4298  end
4299  subroutine csrot (n,cx,incx,cy,incy,c,s)
4300 c
4301 c applies a plane rotation, where the cos and sin (c and s) are real
4302 c and the vectors cx and cy are complex.
4303 c jack dongarra, linpack, 3/11/78.
4304 c
4305  complex cx(1),cy(1),ctemp
4306  real c,s
4307  integer i,incx,incy,ix,iy,n
4308 c
4309  if(n.le.0)return
4310  if(incx.eq.1.and.incy.eq.1)go to 20
4311 c
4312 c code for unequal increments or equal increments not equal
4313 c to 1
4314 c
4315  ix = 1
4316  iy = 1
4317  if(incx.lt.0)ix = (-n+1)*incx + 1
4318  if(incy.lt.0)iy = (-n+1)*incy + 1
4319  do 10 i = 1,n
4320  ctemp = c*cx(ix) + s*cy(iy)
4321  cy(iy) = c*cy(iy) - s*cx(ix)
4322  cx(ix) = ctemp
4323  ix = ix + incx
4324  iy = iy + incy
4325  10 continue
4326  return
4327 c
4328 c code for both increments equal to 1
4329 c
4330  20 do 30 i = 1,n
4331  ctemp = c*cx(i) + s*cy(i)
4332  cy(i) = c*cy(i) - s*cx(i)
4333  cx(i) = ctemp
4334  30 continue
4335  return
4336  end
4337  subroutine csscal(n,sa,cx,incx)
4338 c
4339 c scales a complex vector by a real constant.
4340 c jack dongarra, linpack, 3/11/78.
4341 c modified 3/93 to return if incx .le. 0.
4342 c modified 12/3/93, array(1) declarations changed to array(*)
4343 c
4344  complex cx(*)
4345  real sa
4346  integer i,incx,n,nincx
4347 c
4348  if( n.le.0 .or. incx.le.0 )return
4349  if(incx.eq.1)go to 20
4350 c
4351 c code for increment not equal to 1
4352 c
4353  nincx = n*incx
4354  do 10 i = 1,nincx,incx
4355  cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i)))
4356  10 continue
4357  return
4358 c
4359 c code for increment equal to 1
4360 c
4361  20 do 30 i = 1,n
4362  cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i)))
4363  30 continue
4364  return
4365  end
4366  subroutine cswap (n,cx,incx,cy,incy)
4367 c
4368 c interchanges two vectors.
4369 c jack dongarra, linpack, 3/11/78.
4370 c modified 12/3/93, array(1) declarations changed to array(*)
4371 c
4372  complex cx(*),cy(*),ctemp
4373  integer i,incx,incy,ix,iy,n
4374 c
4375  if(n.le.0)return
4376  if(incx.eq.1.and.incy.eq.1)go to 20
4377 c
4378 c code for unequal increments or equal increments not equal
4379 c to 1
4380 c
4381  ix = 1
4382  iy = 1
4383  if(incx.lt.0)ix = (-n+1)*incx + 1
4384  if(incy.lt.0)iy = (-n+1)*incy + 1
4385  do 10 i = 1,n
4386  ctemp = cx(ix)
4387  cx(ix) = cy(iy)
4388  cy(iy) = ctemp
4389  ix = ix + incx
4390  iy = iy + incy
4391  10 continue
4392  return
4393 c
4394 c code for both increments equal to 1
4395  20 do 30 i = 1,n
4396  ctemp = cx(i)
4397  cx(i) = cy(i)
4398  cy(i) = ctemp
4399  30 continue
4400  return
4401  end
4402  SUBROUTINE csymm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
4403  $ beta, c, ldc )
4404 * .. Scalar Arguments ..
4405  CHARACTER*1 SIDE, UPLO
4406  INTEGER M, N, LDA, LDB, LDC
4407  COMPLEX ALPHA, BETA
4408 * .. Array Arguments ..
4409  COMPLEX A( lda, * ), B( ldb, * ), C( ldc, * )
4410 * ..
4411 *
4412 * Purpose
4413 * =======
4414 *
4415 * CSYMM performs one of the matrix-matrix operations
4416 *
4417 * C := alpha*A*B + beta*C,
4418 *
4419 * or
4420 *
4421 * C := alpha*B*A + beta*C,
4422 *
4423 * where alpha and beta are scalars, A is a symmetric matrix and B and
4424 * C are m by n matrices.
4425 *
4426 * Parameters
4427 * ==========
4428 *
4429 * SIDE - CHARACTER*1.
4430 * On entry, SIDE specifies whether the symmetric matrix A
4431 * appears on the left or right in the operation as follows:
4432 *
4433 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
4434 *
4435 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
4436 *
4437 * Unchanged on exit.
4438 *
4439 * UPLO - CHARACTER*1.
4440 * On entry, UPLO specifies whether the upper or lower
4441 * triangular part of the symmetric matrix A is to be
4442 * referenced as follows:
4443 *
4444 * UPLO = 'U' or 'u' Only the upper triangular part of the
4445 * symmetric matrix is to be referenced.
4446 *
4447 * UPLO = 'L' or 'l' Only the lower triangular part of the
4448 * symmetric matrix is to be referenced.
4449 *
4450 * Unchanged on exit.
4451 *
4452 * M - INTEGER.
4453 * On entry, M specifies the number of rows of the matrix C.
4454 * M must be at least zero.
4455 * Unchanged on exit.
4456 *
4457 * N - INTEGER.
4458 * On entry, N specifies the number of columns of the matrix C.
4459 * N must be at least zero.
4460 * Unchanged on exit.
4461 *
4462 * ALPHA - COMPLEX .
4463 * On entry, ALPHA specifies the scalar alpha.
4464 * Unchanged on exit.
4465 *
4466 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
4467 * m when SIDE = 'L' or 'l' and is n otherwise.
4468 * Before entry with SIDE = 'L' or 'l', the m by m part of
4469 * the array A must contain the symmetric matrix, such that
4470 * when UPLO = 'U' or 'u', the leading m by m upper triangular
4471 * part of the array A must contain the upper triangular part
4472 * of the symmetric matrix and the strictly lower triangular
4473 * part of A is not referenced, and when UPLO = 'L' or 'l',
4474 * the leading m by m lower triangular part of the array A
4475 * must contain the lower triangular part of the symmetric
4476 * matrix and the strictly upper triangular part of A is not
4477 * referenced.
4478 * Before entry with SIDE = 'R' or 'r', the n by n part of
4479 * the array A must contain the symmetric matrix, such that
4480 * when UPLO = 'U' or 'u', the leading n by n upper triangular
4481 * part of the array A must contain the upper triangular part
4482 * of the symmetric matrix and the strictly lower triangular
4483 * part of A is not referenced, and when UPLO = 'L' or 'l',
4484 * the leading n by n lower triangular part of the array A
4485 * must contain the lower triangular part of the symmetric
4486 * matrix and the strictly upper triangular part of A is not
4487 * referenced.
4488 * Unchanged on exit.
4489 *
4490 * LDA - INTEGER.
4491 * On entry, LDA specifies the first dimension of A as declared
4492 * in the calling (sub) program. When SIDE = 'L' or 'l' then
4493 * LDA must be at least max( 1, m ), otherwise LDA must be at
4494 * least max( 1, n ).
4495 * Unchanged on exit.
4496 *
4497 * B - COMPLEX array of DIMENSION ( LDB, n ).
4498 * Before entry, the leading m by n part of the array B must
4499 * contain the matrix B.
4500 * Unchanged on exit.
4501 *
4502 * LDB - INTEGER.
4503 * On entry, LDB specifies the first dimension of B as declared
4504 * in the calling (sub) program. LDB must be at least
4505 * max( 1, m ).
4506 * Unchanged on exit.
4507 *
4508 * BETA - COMPLEX .
4509 * On entry, BETA specifies the scalar beta. When BETA is
4510 * supplied as zero then C need not be set on input.
4511 * Unchanged on exit.
4512 *
4513 * C - COMPLEX array of DIMENSION ( LDC, n ).
4514 * Before entry, the leading m by n part of the array C must
4515 * contain the matrix C, except when beta is zero, in which
4516 * case C need not be set on entry.
4517 * On exit, the array C is overwritten by the m by n updated
4518 * matrix.
4519 *
4520 * LDC - INTEGER.
4521 * On entry, LDC specifies the first dimension of C as declared
4522 * in the calling (sub) program. LDC must be at least
4523 * max( 1, m ).
4524 * Unchanged on exit.
4525 *
4526 *
4527 * Level 3 Blas routine.
4528 *
4529 * -- Written on 8-February-1989.
4530 * Jack Dongarra, Argonne National Laboratory.
4531 * Iain Duff, AERE Harwell.
4532 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
4533 * Sven Hammarling, Numerical Algorithms Group Ltd.
4534 *
4535 *
4536 * .. External Functions ..
4537  LOGICAL LSAME
4538  EXTERNAL lsame
4539 * .. External Subroutines ..
4540  EXTERNAL xerbla
4541 * .. Intrinsic Functions ..
4542  INTRINSIC max
4543 * .. Local Scalars ..
4544  LOGICAL UPPER
4545  INTEGER I, INFO, J, K, NROWA
4546  COMPLEX TEMP1, TEMP2
4547 * .. Parameters ..
4548  COMPLEX ONE
4549  parameter( one = ( 1.0e+0, 0.0e+0 ) )
4550  COMPLEX ZERO
4551  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
4552 * ..
4553 * .. Executable Statements ..
4554 *
4555 * Set NROWA as the number of rows of A.
4556 *
4557  IF( lsame( side, 'L' ) )THEN
4558  nrowa = m
4559  ELSE
4560  nrowa = n
4561  END IF
4562  upper = lsame( uplo, 'U' )
4563 *
4564 * Test the input parameters.
4565 *
4566  info = 0
4567  IF( ( .NOT.lsame( side, 'L' ) ).AND.
4568  $ ( .NOT.lsame( side, 'R' ) ) )THEN
4569  info = 1
4570  ELSE IF( ( .NOT.upper ).AND.
4571  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
4572  info = 2
4573  ELSE IF( m .LT.0 )THEN
4574  info = 3
4575  ELSE IF( n .LT.0 )THEN
4576  info = 4
4577  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
4578  info = 7
4579  ELSE IF( ldb.LT.max( 1, m ) )THEN
4580  info = 9
4581  ELSE IF( ldc.LT.max( 1, m ) )THEN
4582  info = 12
4583  END IF
4584  IF( info.NE.0 )THEN
4585  CALL xerbla( 'CSYMM ', info )
4586  RETURN
4587  END IF
4588 *
4589 * Quick return if possible.
4590 *
4591  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
4592  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
4593  $ RETURN
4594 *
4595 * And when alpha.eq.zero.
4596 *
4597  IF( alpha.EQ.zero )THEN
4598  IF( beta.EQ.zero )THEN
4599  DO 20, j = 1, n
4600  DO 10, i = 1, m
4601  c( i, j ) = zero
4602  10 CONTINUE
4603  20 CONTINUE
4604  ELSE
4605  DO 40, j = 1, n
4606  DO 30, i = 1, m
4607  c( i, j ) = beta*c( i, j )
4608  30 CONTINUE
4609  40 CONTINUE
4610  END IF
4611  RETURN
4612  END IF
4613 *
4614 * Start the operations.
4615 *
4616  IF( lsame( side, 'L' ) )THEN
4617 *
4618 * Form C := alpha*A*B + beta*C.
4619 *
4620  IF( upper )THEN
4621  DO 70, j = 1, n
4622  DO 60, i = 1, m
4623  temp1 = alpha*b( i, j )
4624  temp2 = zero
4625  DO 50, k = 1, i - 1
4626  c( k, j ) = c( k, j ) + temp1 *a( k, i )
4627  temp2 = temp2 + b( k, j )*a( k, i )
4628  50 CONTINUE
4629  IF( beta.EQ.zero )THEN
4630  c( i, j ) = temp1*a( i, i ) + alpha*temp2
4631  ELSE
4632  c( i, j ) = beta *c( i, j ) +
4633  $ temp1*a( i, i ) + alpha*temp2
4634  END IF
4635  60 CONTINUE
4636  70 CONTINUE
4637  ELSE
4638  DO 100, j = 1, n
4639  DO 90, i = m, 1, -1
4640  temp1 = alpha*b( i, j )
4641  temp2 = zero
4642  DO 80, k = i + 1, m
4643  c( k, j ) = c( k, j ) + temp1 *a( k, i )
4644  temp2 = temp2 + b( k, j )*a( k, i )
4645  80 CONTINUE
4646  IF( beta.EQ.zero )THEN
4647  c( i, j ) = temp1*a( i, i ) + alpha*temp2
4648  ELSE
4649  c( i, j ) = beta *c( i, j ) +
4650  $ temp1*a( i, i ) + alpha*temp2
4651  END IF
4652  90 CONTINUE
4653  100 CONTINUE
4654  END IF
4655  ELSE
4656 *
4657 * Form C := alpha*B*A + beta*C.
4658 *
4659  DO 170, j = 1, n
4660  temp1 = alpha*a( j, j )
4661  IF( beta.EQ.zero )THEN
4662  DO 110, i = 1, m
4663  c( i, j ) = temp1*b( i, j )
4664  110 CONTINUE
4665  ELSE
4666  DO 120, i = 1, m
4667  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
4668  120 CONTINUE
4669  END IF
4670  DO 140, k = 1, j - 1
4671  IF( upper )THEN
4672  temp1 = alpha*a( k, j )
4673  ELSE
4674  temp1 = alpha*a( j, k )
4675  END IF
4676  DO 130, i = 1, m
4677  c( i, j ) = c( i, j ) + temp1*b( i, k )
4678  130 CONTINUE
4679  140 CONTINUE
4680  DO 160, k = j + 1, n
4681  IF( upper )THEN
4682  temp1 = alpha*a( j, k )
4683  ELSE
4684  temp1 = alpha*a( k, j )
4685  END IF
4686  DO 150, i = 1, m
4687  c( i, j ) = c( i, j ) + temp1*b( i, k )
4688  150 CONTINUE
4689  160 CONTINUE
4690  170 CONTINUE
4691  END IF
4692 *
4693  RETURN
4694 *
4695 * End of CSYMM .
4696 *
4697  END
4698  SUBROUTINE csyr2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
4699  $ beta, c, ldc )
4700 * .. Scalar Arguments ..
4701  CHARACTER*1 UPLO, TRANS
4702  INTEGER N, K, LDA, LDB, LDC
4703  COMPLEX ALPHA, BETA
4704 * .. Array Arguments ..
4705  COMPLEX A( lda, * ), B( ldb, * ), C( ldc, * )
4706 * ..
4707 *
4708 * Purpose
4709 * =======
4710 *
4711 * CSYR2K performs one of the symmetric rank 2k operations
4712 *
4713 * C := alpha*A*B' + alpha*B*A' + beta*C,
4714 *
4715 * or
4716 *
4717 * C := alpha*A'*B + alpha*B'*A + beta*C,
4718 *
4719 * where alpha and beta are scalars, C is an n by n symmetric matrix
4720 * and A and B are n by k matrices in the first case and k by n
4721 * matrices in the second case.
4722 *
4723 * Parameters
4724 * ==========
4725 *
4726 * UPLO - CHARACTER*1.
4727 * On entry, UPLO specifies whether the upper or lower
4728 * triangular part of the array C is to be referenced as
4729 * follows:
4730 *
4731 * UPLO = 'U' or 'u' Only the upper triangular part of C
4732 * is to be referenced.
4733 *
4734 * UPLO = 'L' or 'l' Only the lower triangular part of C
4735 * is to be referenced.
4736 *
4737 * Unchanged on exit.
4738 *
4739 * TRANS - CHARACTER*1.
4740 * On entry, TRANS specifies the operation to be performed as
4741 * follows:
4742 *
4743 * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
4744 * beta*C.
4745 *
4746 * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
4747 * beta*C.
4748 *
4749 * Unchanged on exit.
4750 *
4751 * N - INTEGER.
4752 * On entry, N specifies the order of the matrix C. N must be
4753 * at least zero.
4754 * Unchanged on exit.
4755 *
4756 * K - INTEGER.
4757 * On entry with TRANS = 'N' or 'n', K specifies the number
4758 * of columns of the matrices A and B, and on entry with
4759 * TRANS = 'T' or 't', K specifies the number of rows of the
4760 * matrices A and B. K must be at least zero.
4761 * Unchanged on exit.
4762 *
4763 * ALPHA - COMPLEX .
4764 * On entry, ALPHA specifies the scalar alpha.
4765 * Unchanged on exit.
4766 *
4767 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
4768 * k when TRANS = 'N' or 'n', and is n otherwise.
4769 * Before entry with TRANS = 'N' or 'n', the leading n by k
4770 * part of the array A must contain the matrix A, otherwise
4771 * the leading k by n part of the array A must contain the
4772 * matrix A.
4773 * Unchanged on exit.
4774 *
4775 * LDA - INTEGER.
4776 * On entry, LDA specifies the first dimension of A as declared
4777 * in the calling (sub) program. When TRANS = 'N' or 'n'
4778 * then LDA must be at least max( 1, n ), otherwise LDA must
4779 * be at least max( 1, k ).
4780 * Unchanged on exit.
4781 *
4782 * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is
4783 * k when TRANS = 'N' or 'n', and is n otherwise.
4784 * Before entry with TRANS = 'N' or 'n', the leading n by k
4785 * part of the array B must contain the matrix B, otherwise
4786 * the leading k by n part of the array B must contain the
4787 * matrix B.
4788 * Unchanged on exit.
4789 *
4790 * LDB - INTEGER.
4791 * On entry, LDB specifies the first dimension of B as declared
4792 * in the calling (sub) program. When TRANS = 'N' or 'n'
4793 * then LDB must be at least max( 1, n ), otherwise LDB must
4794 * be at least max( 1, k ).
4795 * Unchanged on exit.
4796 *
4797 * BETA - COMPLEX .
4798 * On entry, BETA specifies the scalar beta.
4799 * Unchanged on exit.
4800 *
4801 * C - COMPLEX array of DIMENSION ( LDC, n ).
4802 * Before entry with UPLO = 'U' or 'u', the leading n by n
4803 * upper triangular part of the array C must contain the upper
4804 * triangular part of the symmetric matrix and the strictly
4805 * lower triangular part of C is not referenced. On exit, the
4806 * upper triangular part of the array C is overwritten by the
4807 * upper triangular part of the updated matrix.
4808 * Before entry with UPLO = 'L' or 'l', the leading n by n
4809 * lower triangular part of the array C must contain the lower
4810 * triangular part of the symmetric matrix and the strictly
4811 * upper triangular part of C is not referenced. On exit, the
4812 * lower triangular part of the array C is overwritten by the
4813 * lower triangular part of the updated matrix.
4814 *
4815 * LDC - INTEGER.
4816 * On entry, LDC specifies the first dimension of C as declared
4817 * in the calling (sub) program. LDC must be at least
4818 * max( 1, n ).
4819 * Unchanged on exit.
4820 *
4821 *
4822 * Level 3 Blas routine.
4823 *
4824 * -- Written on 8-February-1989.
4825 * Jack Dongarra, Argonne National Laboratory.
4826 * Iain Duff, AERE Harwell.
4827 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
4828 * Sven Hammarling, Numerical Algorithms Group Ltd.
4829 *
4830 *
4831 * .. External Functions ..
4832  LOGICAL LSAME
4833  EXTERNAL lsame
4834 * .. External Subroutines ..
4835  EXTERNAL xerbla
4836 * .. Intrinsic Functions ..
4837  INTRINSIC max
4838 * .. Local Scalars ..
4839  LOGICAL UPPER
4840  INTEGER I, INFO, J, L, NROWA
4841  COMPLEX TEMP1, TEMP2
4842 * .. Parameters ..
4843  COMPLEX ONE
4844  parameter( one = ( 1.0e+0, 0.0e+0 ) )
4845  COMPLEX ZERO
4846  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
4847 * ..
4848 * .. Executable Statements ..
4849 *
4850 * Test the input parameters.
4851 *
4852  IF( lsame( trans, 'N' ) )THEN
4853  nrowa = n
4854  ELSE
4855  nrowa = k
4856  END IF
4857  upper = lsame( uplo, 'U' )
4858 *
4859  info = 0
4860  IF( ( .NOT.upper ).AND.
4861  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
4862  info = 1
4863  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
4864  $ ( .NOT.lsame( trans, 'T' ) ) )THEN
4865  info = 2
4866  ELSE IF( n .LT.0 )THEN
4867  info = 3
4868  ELSE IF( k .LT.0 )THEN
4869  info = 4
4870  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
4871  info = 7
4872  ELSE IF( ldb.LT.max( 1, nrowa ) )THEN
4873  info = 9
4874  ELSE IF( ldc.LT.max( 1, n ) )THEN
4875  info = 12
4876  END IF
4877  IF( info.NE.0 )THEN
4878  CALL xerbla( 'CSYR2K', info )
4879  RETURN
4880  END IF
4881 *
4882 * Quick return if possible.
4883 *
4884  IF( ( n.EQ.0 ).OR.
4885  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
4886  $ RETURN
4887 *
4888 * And when alpha.eq.zero.
4889 *
4890  IF( alpha.EQ.zero )THEN
4891  IF( upper )THEN
4892  IF( beta.EQ.zero )THEN
4893  DO 20, j = 1, n
4894  DO 10, i = 1, j
4895  c( i, j ) = zero
4896  10 CONTINUE
4897  20 CONTINUE
4898  ELSE
4899  DO 40, j = 1, n
4900  DO 30, i = 1, j
4901  c( i, j ) = beta*c( i, j )
4902  30 CONTINUE
4903  40 CONTINUE
4904  END IF
4905  ELSE
4906  IF( beta.EQ.zero )THEN
4907  DO 60, j = 1, n
4908  DO 50, i = j, n
4909  c( i, j ) = zero
4910  50 CONTINUE
4911  60 CONTINUE
4912  ELSE
4913  DO 80, j = 1, n
4914  DO 70, i = j, n
4915  c( i, j ) = beta*c( i, j )
4916  70 CONTINUE
4917  80 CONTINUE
4918  END IF
4919  END IF
4920  RETURN
4921  END IF
4922 *
4923 * Start the operations.
4924 *
4925  IF( lsame( trans, 'N' ) )THEN
4926 *
4927 * Form C := alpha*A*B' + alpha*B*A' + C.
4928 *
4929  IF( upper )THEN
4930  DO 130, j = 1, n
4931  IF( beta.EQ.zero )THEN
4932  DO 90, i = 1, j
4933  c( i, j ) = zero
4934  90 CONTINUE
4935  ELSE IF( beta.NE.one )THEN
4936  DO 100, i = 1, j
4937  c( i, j ) = beta*c( i, j )
4938  100 CONTINUE
4939  END IF
4940  DO 120, l = 1, k
4941  IF( ( a( j, l ).NE.zero ).OR.
4942  $ ( b( j, l ).NE.zero ) )THEN
4943  temp1 = alpha*b( j, l )
4944  temp2 = alpha*a( j, l )
4945  DO 110, i = 1, j
4946  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
4947  $ b( i, l )*temp2
4948  110 CONTINUE
4949  END IF
4950  120 CONTINUE
4951  130 CONTINUE
4952  ELSE
4953  DO 180, j = 1, n
4954  IF( beta.EQ.zero )THEN
4955  DO 140, i = j, n
4956  c( i, j ) = zero
4957  140 CONTINUE
4958  ELSE IF( beta.NE.one )THEN
4959  DO 150, i = j, n
4960  c( i, j ) = beta*c( i, j )
4961  150 CONTINUE
4962  END IF
4963  DO 170, l = 1, k
4964  IF( ( a( j, l ).NE.zero ).OR.
4965  $ ( b( j, l ).NE.zero ) )THEN
4966  temp1 = alpha*b( j, l )
4967  temp2 = alpha*a( j, l )
4968  DO 160, i = j, n
4969  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
4970  $ b( i, l )*temp2
4971  160 CONTINUE
4972  END IF
4973  170 CONTINUE
4974  180 CONTINUE
4975  END IF
4976  ELSE
4977 *
4978 * Form C := alpha*A'*B + alpha*B'*A + C.
4979 *
4980  IF( upper )THEN
4981  DO 210, j = 1, n
4982  DO 200, i = 1, j
4983  temp1 = zero
4984  temp2 = zero
4985  DO 190, l = 1, k
4986  temp1 = temp1 + a( l, i )*b( l, j )
4987  temp2 = temp2 + b( l, i )*a( l, j )
4988  190 CONTINUE
4989  IF( beta.EQ.zero )THEN
4990  c( i, j ) = alpha*temp1 + alpha*temp2
4991  ELSE
4992  c( i, j ) = beta *c( i, j ) +
4993  $ alpha*temp1 + alpha*temp2
4994  END IF
4995  200 CONTINUE
4996  210 CONTINUE
4997  ELSE
4998  DO 240, j = 1, n
4999  DO 230, i = j, n
5000  temp1 = zero
5001  temp2 = zero
5002  DO 220, l = 1, k
5003  temp1 = temp1 + a( l, i )*b( l, j )
5004  temp2 = temp2 + b( l, i )*a( l, j )
5005  220 CONTINUE
5006  IF( beta.EQ.zero )THEN
5007  c( i, j ) = alpha*temp1 + alpha*temp2
5008  ELSE
5009  c( i, j ) = beta *c( i, j ) +
5010  $ alpha*temp1 + alpha*temp2
5011  END IF
5012  230 CONTINUE
5013  240 CONTINUE
5014  END IF
5015  END IF
5016 *
5017  RETURN
5018 *
5019 * End of CSYR2K.
5020 *
5021  END
5022  SUBROUTINE csyrk ( UPLO, TRANS, N, K, ALPHA, A, LDA,
5023  $ beta, c, ldc )
5024 * .. Scalar Arguments ..
5025  CHARACTER*1 UPLO, TRANS
5026  INTEGER N, K, LDA, LDC
5027  COMPLEX ALPHA, BETA
5028 * .. Array Arguments ..
5029  COMPLEX A( lda, * ), C( ldc, * )
5030 * ..
5031 *
5032 * Purpose
5033 * =======
5034 *
5035 * CSYRK performs one of the symmetric rank k operations
5036 *
5037 * C := alpha*A*A' + beta*C,
5038 *
5039 * or
5040 *
5041 * C := alpha*A'*A + beta*C,
5042 *
5043 * where alpha and beta are scalars, C is an n by n symmetric matrix
5044 * and A is an n by k matrix in the first case and a k by n matrix
5045 * in the second case.
5046 *
5047 * Parameters
5048 * ==========
5049 *
5050 * UPLO - CHARACTER*1.
5051 * On entry, UPLO specifies whether the upper or lower
5052 * triangular part of the array C is to be referenced as
5053 * follows:
5054 *
5055 * UPLO = 'U' or 'u' Only the upper triangular part of C
5056 * is to be referenced.
5057 *
5058 * UPLO = 'L' or 'l' Only the lower triangular part of C
5059 * is to be referenced.
5060 *
5061 * Unchanged on exit.
5062 *
5063 * TRANS - CHARACTER*1.
5064 * On entry, TRANS specifies the operation to be performed as
5065 * follows:
5066 *
5067 * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
5068 *
5069 * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
5070 *
5071 * Unchanged on exit.
5072 *
5073 * N - INTEGER.
5074 * On entry, N specifies the order of the matrix C. N must be
5075 * at least zero.
5076 * Unchanged on exit.
5077 *
5078 * K - INTEGER.
5079 * On entry with TRANS = 'N' or 'n', K specifies the number
5080 * of columns of the matrix A, and on entry with
5081 * TRANS = 'T' or 't', K specifies the number of rows of the
5082 * matrix A. K must be at least zero.
5083 * Unchanged on exit.
5084 *
5085 * ALPHA - COMPLEX .
5086 * On entry, ALPHA specifies the scalar alpha.
5087 * Unchanged on exit.
5088 *
5089 * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
5090 * k when TRANS = 'N' or 'n', and is n otherwise.
5091 * Before entry with TRANS = 'N' or 'n', the leading n by k
5092 * part of the array A must contain the matrix A, otherwise
5093 * the leading k by n part of the array A must contain the
5094 * matrix A.
5095 * Unchanged on exit.
5096 *
5097 * LDA - INTEGER.
5098 * On entry, LDA specifies the first dimension of A as declared
5099 * in the calling (sub) program. When TRANS = 'N' or 'n'
5100 * then LDA must be at least max( 1, n ), otherwise LDA must
5101 * be at least max( 1, k ).
5102 * Unchanged on exit.
5103 *
5104 * BETA - COMPLEX .
5105 * On entry, BETA specifies the scalar beta.
5106 * Unchanged on exit.
5107 *
5108 * C - COMPLEX array of DIMENSION ( LDC, n ).
5109 * Before entry with UPLO = 'U' or 'u', the leading n by n
5110 * upper triangular part of the array C must contain the upper
5111 * triangular part of the symmetric matrix and the strictly
5112 * lower triangular part of C is not referenced. On exit, the
5113 * upper triangular part of the array C is overwritten by the
5114 * upper triangular part of the updated matrix.
5115 * Before entry with UPLO = 'L' or 'l', the leading n by n
5116 * lower triangular part of the array C must contain the lower
5117 * triangular part of the symmetric matrix and the strictly
5118 * upper triangular part of C is not referenced. On exit, the
5119 * lower triangular part of the array C is overwritten by the
5120 * lower triangular part of the updated matrix.
5121 *
5122 * LDC - INTEGER.
5123 * On entry, LDC specifies the first dimension of C as declared
5124 * in the calling (sub) program. LDC must be at least
5125 * max( 1, n ).
5126 * Unchanged on exit.
5127 *
5128 *
5129 * Level 3 Blas routine.
5130 *
5131 * -- Written on 8-February-1989.
5132 * Jack Dongarra, Argonne National Laboratory.
5133 * Iain Duff, AERE Harwell.
5134 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
5135 * Sven Hammarling, Numerical Algorithms Group Ltd.
5136 *
5137 *
5138 * .. External Functions ..
5139  LOGICAL LSAME
5140  EXTERNAL lsame
5141 * .. External Subroutines ..
5142  EXTERNAL xerbla
5143 * .. Intrinsic Functions ..
5144  INTRINSIC max
5145 * .. Local Scalars ..
5146  LOGICAL UPPER
5147  INTEGER I, INFO, J, L, NROWA
5148  COMPLEX TEMP
5149 * .. Parameters ..
5150  COMPLEX ONE
5151  parameter( one = ( 1.0e+0, 0.0e+0 ) )
5152  COMPLEX ZERO
5153  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
5154 * ..
5155 * .. Executable Statements ..
5156 *
5157 * Test the input parameters.
5158 *
5159  IF( lsame( trans, 'N' ) )THEN
5160  nrowa = n
5161  ELSE
5162  nrowa = k
5163  END IF
5164  upper = lsame( uplo, 'U' )
5165 *
5166  info = 0
5167  IF( ( .NOT.upper ).AND.
5168  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
5169  info = 1
5170  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
5171  $ ( .NOT.lsame( trans, 'T' ) ) )THEN
5172  info = 2
5173  ELSE IF( n .LT.0 )THEN
5174  info = 3
5175  ELSE IF( k .LT.0 )THEN
5176  info = 4
5177  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
5178  info = 7
5179  ELSE IF( ldc.LT.max( 1, n ) )THEN
5180  info = 10
5181  END IF
5182  IF( info.NE.0 )THEN
5183  CALL xerbla( 'CSYRK ', info )
5184  RETURN
5185  END IF
5186 *
5187 * Quick return if possible.
5188 *
5189  IF( ( n.EQ.0 ).OR.
5190  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
5191  $ RETURN
5192 *
5193 * And when alpha.eq.zero.
5194 *
5195  IF( alpha.EQ.zero )THEN
5196  IF( upper )THEN
5197  IF( beta.EQ.zero )THEN
5198  DO 20, j = 1, n
5199  DO 10, i = 1, j
5200  c( i, j ) = zero
5201  10 CONTINUE
5202  20 CONTINUE
5203  ELSE
5204  DO 40, j = 1, n
5205  DO 30, i = 1, j
5206  c( i, j ) = beta*c( i, j )
5207  30 CONTINUE
5208  40 CONTINUE
5209  END IF
5210  ELSE
5211  IF( beta.EQ.zero )THEN
5212  DO 60, j = 1, n
5213  DO 50, i = j, n
5214  c( i, j ) = zero
5215  50 CONTINUE
5216  60 CONTINUE
5217  ELSE
5218  DO 80, j = 1, n
5219  DO 70, i = j, n
5220  c( i, j ) = beta*c( i, j )
5221  70 CONTINUE
5222  80 CONTINUE
5223  END IF
5224  END IF
5225  RETURN
5226  END IF
5227 *
5228 * Start the operations.
5229 *
5230  IF( lsame( trans, 'N' ) )THEN
5231 *
5232 * Form C := alpha*A*A' + beta*C.
5233 *
5234  IF( upper )THEN
5235  DO 130, j = 1, n
5236  IF( beta.EQ.zero )THEN
5237  DO 90, i = 1, j
5238  c( i, j ) = zero
5239  90 CONTINUE
5240  ELSE IF( beta.NE.one )THEN
5241  DO 100, i = 1, j
5242  c( i, j ) = beta*c( i, j )
5243  100 CONTINUE
5244  END IF
5245  DO 120, l = 1, k
5246  IF( a( j, l ).NE.zero )THEN
5247  temp = alpha*a( j, l )
5248  DO 110, i = 1, j
5249  c( i, j ) = c( i, j ) + temp*a( i, l )
5250  110 CONTINUE
5251  END IF
5252  120 CONTINUE
5253  130 CONTINUE
5254  ELSE
5255  DO 180, j = 1, n
5256  IF( beta.EQ.zero )THEN
5257  DO 140, i = j, n
5258  c( i, j ) = zero
5259  140 CONTINUE
5260  ELSE IF( beta.NE.one )THEN
5261  DO 150, i = j, n
5262  c( i, j ) = beta*c( i, j )
5263  150 CONTINUE
5264  END IF
5265  DO 170, l = 1, k
5266  IF( a( j, l ).NE.zero )THEN
5267  temp = alpha*a( j, l )
5268  DO 160, i = j, n
5269  c( i, j ) = c( i, j ) + temp*a( i, l )
5270  160 CONTINUE
5271  END IF
5272  170 CONTINUE
5273  180 CONTINUE
5274  END IF
5275  ELSE
5276 *
5277 * Form C := alpha*A'*A + beta*C.
5278 *
5279  IF( upper )THEN
5280  DO 210, j = 1, n
5281  DO 200, i = 1, j
5282  temp = zero
5283  DO 190, l = 1, k
5284  temp = temp + a( l, i )*a( l, j )
5285  190 CONTINUE
5286  IF( beta.EQ.zero )THEN
5287  c( i, j ) = alpha*temp
5288  ELSE
5289  c( i, j ) = alpha*temp + beta*c( i, j )
5290  END IF
5291  200 CONTINUE
5292  210 CONTINUE
5293  ELSE
5294  DO 240, j = 1, n
5295  DO 230, i = j, n
5296  temp = zero
5297  DO 220, l = 1, k
5298  temp = temp + a( l, i )*a( l, j )
5299  220 CONTINUE
5300  IF( beta.EQ.zero )THEN
5301  c( i, j ) = alpha*temp
5302  ELSE
5303  c( i, j ) = alpha*temp + beta*c( i, j )
5304  END IF
5305  230 CONTINUE
5306  240 CONTINUE
5307  END IF
5308  END IF
5309 *
5310  RETURN
5311 *
5312 * End of CSYRK .
5313 *
5314  END
5315  SUBROUTINE ctbmv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
5316 * .. Scalar Arguments ..
5317  INTEGER INCX, K, LDA, N
5318  CHARACTER*1 DIAG, TRANS, UPLO
5319 * .. Array Arguments ..
5320  COMPLEX A( lda, * ), X( * )
5321 * ..
5322 *
5323 * Purpose
5324 * =======
5325 *
5326 * CTBMV performs one of the matrix-vector operations
5327 *
5328 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
5329 *
5330 * where x is an n element vector and A is an n by n unit, or non-unit,
5331 * upper or lower triangular band matrix, with ( k + 1 ) diagonals.
5332 *
5333 * Parameters
5334 * ==========
5335 *
5336 * UPLO - CHARACTER*1.
5337 * On entry, UPLO specifies whether the matrix is an upper or
5338 * lower triangular matrix as follows:
5339 *
5340 * UPLO = 'U' or 'u' A is an upper triangular matrix.
5341 *
5342 * UPLO = 'L' or 'l' A is a lower triangular matrix.
5343 *
5344 * Unchanged on exit.
5345 *
5346 * TRANS - CHARACTER*1.
5347 * On entry, TRANS specifies the operation to be performed as
5348 * follows:
5349 *
5350 * TRANS = 'N' or 'n' x := A*x.
5351 *
5352 * TRANS = 'T' or 't' x := A'*x.
5353 *
5354 * TRANS = 'C' or 'c' x := conjg( A' )*x.
5355 *
5356 * Unchanged on exit.
5357 *
5358 * DIAG - CHARACTER*1.
5359 * On entry, DIAG specifies whether or not A is unit
5360 * triangular as follows:
5361 *
5362 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
5363 *
5364 * DIAG = 'N' or 'n' A is not assumed to be unit
5365 * triangular.
5366 *
5367 * Unchanged on exit.
5368 *
5369 * N - INTEGER.
5370 * On entry, N specifies the order of the matrix A.
5371 * N must be at least zero.
5372 * Unchanged on exit.
5373 *
5374 * K - INTEGER.
5375 * On entry with UPLO = 'U' or 'u', K specifies the number of
5376 * super-diagonals of the matrix A.
5377 * On entry with UPLO = 'L' or 'l', K specifies the number of
5378 * sub-diagonals of the matrix A.
5379 * K must satisfy 0 .le. K.
5380 * Unchanged on exit.
5381 *
5382 * A - COMPLEX array of DIMENSION ( LDA, n ).
5383 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
5384 * by n part of the array A must contain the upper triangular
5385 * band part of the matrix of coefficients, supplied column by
5386 * column, with the leading diagonal of the matrix in row
5387 * ( k + 1 ) of the array, the first super-diagonal starting at
5388 * position 2 in row k, and so on. The top left k by k triangle
5389 * of the array A is not referenced.
5390 * The following program segment will transfer an upper
5391 * triangular band matrix from conventional full matrix storage
5392 * to band storage:
5393 *
5394 * DO 20, J = 1, N
5395 * M = K + 1 - J
5396 * DO 10, I = MAX( 1, J - K ), J
5397 * A( M + I, J ) = matrix( I, J )
5398 * 10 CONTINUE
5399 * 20 CONTINUE
5400 *
5401 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
5402 * by n part of the array A must contain the lower triangular
5403 * band part of the matrix of coefficients, supplied column by
5404 * column, with the leading diagonal of the matrix in row 1 of
5405 * the array, the first sub-diagonal starting at position 1 in
5406 * row 2, and so on. The bottom right k by k triangle of the
5407 * array A is not referenced.
5408 * The following program segment will transfer a lower
5409 * triangular band matrix from conventional full matrix storage
5410 * to band storage:
5411 *
5412 * DO 20, J = 1, N
5413 * M = 1 - J
5414 * DO 10, I = J, MIN( N, J + K )
5415 * A( M + I, J ) = matrix( I, J )
5416 * 10 CONTINUE
5417 * 20 CONTINUE
5418 *
5419 * Note that when DIAG = 'U' or 'u' the elements of the array A
5420 * corresponding to the diagonal elements of the matrix are not
5421 * referenced, but are assumed to be unity.
5422 * Unchanged on exit.
5423 *
5424 * LDA - INTEGER.
5425 * On entry, LDA specifies the first dimension of A as declared
5426 * in the calling (sub) program. LDA must be at least
5427 * ( k + 1 ).
5428 * Unchanged on exit.
5429 *
5430 * X - COMPLEX array of dimension at least
5431 * ( 1 + ( n - 1 )*abs( INCX ) ).
5432 * Before entry, the incremented array X must contain the n
5433 * element vector x. On exit, X is overwritten with the
5434 * tranformed vector x.
5435 *
5436 * INCX - INTEGER.
5437 * On entry, INCX specifies the increment for the elements of
5438 * X. INCX must not be zero.
5439 * Unchanged on exit.
5440 *
5441 *
5442 * Level 2 Blas routine.
5443 *
5444 * -- Written on 22-October-1986.
5445 * Jack Dongarra, Argonne National Lab.
5446 * Jeremy Du Croz, Nag Central Office.
5447 * Sven Hammarling, Nag Central Office.
5448 * Richard Hanson, Sandia National Labs.
5449 *
5450 *
5451 * .. Parameters ..
5452  COMPLEX ZERO
5453  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
5454 * .. Local Scalars ..
5455  COMPLEX TEMP
5456  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
5457  LOGICAL NOCONJ, NOUNIT
5458 * .. External Functions ..
5459  LOGICAL LSAME
5460  EXTERNAL lsame
5461 * .. External Subroutines ..
5462  EXTERNAL xerbla
5463 * .. Intrinsic Functions ..
5464  INTRINSIC conjg, max, min
5465 * ..
5466 * .. Executable Statements ..
5467 *
5468 * Test the input parameters.
5469 *
5470  info = 0
5471  IF ( .NOT.lsame( uplo , 'U' ).AND.
5472  $ .NOT.lsame( uplo , 'L' ) )THEN
5473  info = 1
5474  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
5475  $ .NOT.lsame( trans, 'T' ).AND.
5476  $ .NOT.lsame( trans, 'C' ) )THEN
5477  info = 2
5478  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
5479  $ .NOT.lsame( diag , 'N' ) )THEN
5480  info = 3
5481  ELSE IF( n.LT.0 )THEN
5482  info = 4
5483  ELSE IF( k.LT.0 )THEN
5484  info = 5
5485  ELSE IF( lda.LT.( k + 1 ) )THEN
5486  info = 7
5487  ELSE IF( incx.EQ.0 )THEN
5488  info = 9
5489  END IF
5490  IF( info.NE.0 )THEN
5491  CALL xerbla( 'CTBMV ', info )
5492  RETURN
5493  END IF
5494 *
5495 * Quick return if possible.
5496 *
5497  IF( n.EQ.0 )
5498  $ RETURN
5499 *
5500  noconj = lsame( trans, 'T' )
5501  nounit = lsame( diag , 'N' )
5502 *
5503 * Set up the start point in X if the increment is not unity. This
5504 * will be ( N - 1 )*INCX too small for descending loops.
5505 *
5506  IF( incx.LE.0 )THEN
5507  kx = 1 - ( n - 1 )*incx
5508  ELSE IF( incx.NE.1 )THEN
5509  kx = 1
5510  END IF
5511 *
5512 * Start the operations. In this version the elements of A are
5513 * accessed sequentially with one pass through A.
5514 *
5515  IF( lsame( trans, 'N' ) )THEN
5516 *
5517 * Form x := A*x.
5518 *
5519  IF( lsame( uplo, 'U' ) )THEN
5520  kplus1 = k + 1
5521  IF( incx.EQ.1 )THEN
5522  DO 20, j = 1, n
5523  IF( x( j ).NE.zero )THEN
5524  temp = x( j )
5525  l = kplus1 - j
5526  DO 10, i = max( 1, j - k ), j - 1
5527  x( i ) = x( i ) + temp*a( l + i, j )
5528  10 CONTINUE
5529  IF( nounit )
5530  $ x( j ) = x( j )*a( kplus1, j )
5531  END IF
5532  20 CONTINUE
5533  ELSE
5534  jx = kx
5535  DO 40, j = 1, n
5536  IF( x( jx ).NE.zero )THEN
5537  temp = x( jx )
5538  ix = kx
5539  l = kplus1 - j
5540  DO 30, i = max( 1, j - k ), j - 1
5541  x( ix ) = x( ix ) + temp*a( l + i, j )
5542  ix = ix + incx
5543  30 CONTINUE
5544  IF( nounit )
5545  $ x( jx ) = x( jx )*a( kplus1, j )
5546  END IF
5547  jx = jx + incx
5548  IF( j.GT.k )
5549  $ kx = kx + incx
5550  40 CONTINUE
5551  END IF
5552  ELSE
5553  IF( incx.EQ.1 )THEN
5554  DO 60, j = n, 1, -1
5555  IF( x( j ).NE.zero )THEN
5556  temp = x( j )
5557  l = 1 - j
5558  DO 50, i = min( n, j + k ), j + 1, -1
5559  x( i ) = x( i ) + temp*a( l + i, j )
5560  50 CONTINUE
5561  IF( nounit )
5562  $ x( j ) = x( j )*a( 1, j )
5563  END IF
5564  60 CONTINUE
5565  ELSE
5566  kx = kx + ( n - 1 )*incx
5567  jx = kx
5568  DO 80, j = n, 1, -1
5569  IF( x( jx ).NE.zero )THEN
5570  temp = x( jx )
5571  ix = kx
5572  l = 1 - j
5573  DO 70, i = min( n, j + k ), j + 1, -1
5574  x( ix ) = x( ix ) + temp*a( l + i, j )
5575  ix = ix - incx
5576  70 CONTINUE
5577  IF( nounit )
5578  $ x( jx ) = x( jx )*a( 1, j )
5579  END IF
5580  jx = jx - incx
5581  IF( ( n - j ).GE.k )
5582  $ kx = kx - incx
5583  80 CONTINUE
5584  END IF
5585  END IF
5586  ELSE
5587 *
5588 * Form x := A'*x or x := conjg( A' )*x.
5589 *
5590  IF( lsame( uplo, 'U' ) )THEN
5591  kplus1 = k + 1
5592  IF( incx.EQ.1 )THEN
5593  DO 110, j = n, 1, -1
5594  temp = x( j )
5595  l = kplus1 - j
5596  IF( noconj )THEN
5597  IF( nounit )
5598  $ temp = temp*a( kplus1, j )
5599  DO 90, i = j - 1, max( 1, j - k ), -1
5600  temp = temp + a( l + i, j )*x( i )
5601  90 CONTINUE
5602  ELSE
5603  IF( nounit )
5604  $ temp = temp*conjg( a( kplus1, j ) )
5605  DO 100, i = j - 1, max( 1, j - k ), -1
5606  temp = temp + conjg( a( l + i, j ) )*x( i )
5607  100 CONTINUE
5608  END IF
5609  x( j ) = temp
5610  110 CONTINUE
5611  ELSE
5612  kx = kx + ( n - 1 )*incx
5613  jx = kx
5614  DO 140, j = n, 1, -1
5615  temp = x( jx )
5616  kx = kx - incx
5617  ix = kx
5618  l = kplus1 - j
5619  IF( noconj )THEN
5620  IF( nounit )
5621  $ temp = temp*a( kplus1, j )
5622  DO 120, i = j - 1, max( 1, j - k ), -1
5623  temp = temp + a( l + i, j )*x( ix )
5624  ix = ix - incx
5625  120 CONTINUE
5626  ELSE
5627  IF( nounit )
5628  $ temp = temp*conjg( a( kplus1, j ) )
5629  DO 130, i = j - 1, max( 1, j - k ), -1
5630  temp = temp + conjg( a( l + i, j ) )*x( ix )
5631  ix = ix - incx
5632  130 CONTINUE
5633  END IF
5634  x( jx ) = temp
5635  jx = jx - incx
5636  140 CONTINUE
5637  END IF
5638  ELSE
5639  IF( incx.EQ.1 )THEN
5640  DO 170, j = 1, n
5641  temp = x( j )
5642  l = 1 - j
5643  IF( noconj )THEN
5644  IF( nounit )
5645  $ temp = temp*a( 1, j )
5646  DO 150, i = j + 1, min( n, j + k )
5647  temp = temp + a( l + i, j )*x( i )
5648  150 CONTINUE
5649  ELSE
5650  IF( nounit )
5651  $ temp = temp*conjg( a( 1, j ) )
5652  DO 160, i = j + 1, min( n, j + k )
5653  temp = temp + conjg( a( l + i, j ) )*x( i )
5654  160 CONTINUE
5655  END IF
5656  x( j ) = temp
5657  170 CONTINUE
5658  ELSE
5659  jx = kx
5660  DO 200, j = 1, n
5661  temp = x( jx )
5662  kx = kx + incx
5663  ix = kx
5664  l = 1 - j
5665  IF( noconj )THEN
5666  IF( nounit )
5667  $ temp = temp*a( 1, j )
5668  DO 180, i = j + 1, min( n, j + k )
5669  temp = temp + a( l + i, j )*x( ix )
5670  ix = ix + incx
5671  180 CONTINUE
5672  ELSE
5673  IF( nounit )
5674  $ temp = temp*conjg( a( 1, j ) )
5675  DO 190, i = j + 1, min( n, j + k )
5676  temp = temp + conjg( a( l + i, j ) )*x( ix )
5677  ix = ix + incx
5678  190 CONTINUE
5679  END IF
5680  x( jx ) = temp
5681  jx = jx + incx
5682  200 CONTINUE
5683  END IF
5684  END IF
5685  END IF
5686 *
5687  RETURN
5688 *
5689 * End of CTBMV .
5690 *
5691  END
5692  SUBROUTINE ctbsv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
5693 * .. Scalar Arguments ..
5694  INTEGER INCX, K, LDA, N
5695  CHARACTER*1 DIAG, TRANS, UPLO
5696 * .. Array Arguments ..
5697  COMPLEX A( lda, * ), X( * )
5698 * ..
5699 *
5700 * Purpose
5701 * =======
5702 *
5703 * CTBSV solves one of the systems of equations
5704 *
5705 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
5706 *
5707 * where b and x are n element vectors and A is an n by n unit, or
5708 * non-unit, upper or lower triangular band matrix, with ( k + 1 )
5709 * diagonals.
5710 *
5711 * No test for singularity or near-singularity is included in this
5712 * routine. Such tests must be performed before calling this routine.
5713 *
5714 * Parameters
5715 * ==========
5716 *
5717 * UPLO - CHARACTER*1.
5718 * On entry, UPLO specifies whether the matrix is an upper or
5719 * lower triangular matrix as follows:
5720 *
5721 * UPLO = 'U' or 'u' A is an upper triangular matrix.
5722 *
5723 * UPLO = 'L' or 'l' A is a lower triangular matrix.
5724 *
5725 * Unchanged on exit.
5726 *
5727 * TRANS - CHARACTER*1.
5728 * On entry, TRANS specifies the equations to be solved as
5729 * follows:
5730 *
5731 * TRANS = 'N' or 'n' A*x = b.
5732 *
5733 * TRANS = 'T' or 't' A'*x = b.
5734 *
5735 * TRANS = 'C' or 'c' conjg( A' )*x = b.
5736 *
5737 * Unchanged on exit.
5738 *
5739 * DIAG - CHARACTER*1.
5740 * On entry, DIAG specifies whether or not A is unit
5741 * triangular as follows:
5742 *
5743 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
5744 *
5745 * DIAG = 'N' or 'n' A is not assumed to be unit
5746 * triangular.
5747 *
5748 * Unchanged on exit.
5749 *
5750 * N - INTEGER.
5751 * On entry, N specifies the order of the matrix A.
5752 * N must be at least zero.
5753 * Unchanged on exit.
5754 *
5755 * K - INTEGER.
5756 * On entry with UPLO = 'U' or 'u', K specifies the number of
5757 * super-diagonals of the matrix A.
5758 * On entry with UPLO = 'L' or 'l', K specifies the number of
5759 * sub-diagonals of the matrix A.
5760 * K must satisfy 0 .le. K.
5761 * Unchanged on exit.
5762 *
5763 * A - COMPLEX array of DIMENSION ( LDA, n ).
5764 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
5765 * by n part of the array A must contain the upper triangular
5766 * band part of the matrix of coefficients, supplied column by
5767 * column, with the leading diagonal of the matrix in row
5768 * ( k + 1 ) of the array, the first super-diagonal starting at
5769 * position 2 in row k, and so on. The top left k by k triangle
5770 * of the array A is not referenced.
5771 * The following program segment will transfer an upper
5772 * triangular band matrix from conventional full matrix storage
5773 * to band storage:
5774 *
5775 * DO 20, J = 1, N
5776 * M = K + 1 - J
5777 * DO 10, I = MAX( 1, J - K ), J
5778 * A( M + I, J ) = matrix( I, J )
5779 * 10 CONTINUE
5780 * 20 CONTINUE
5781 *
5782 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
5783 * by n part of the array A must contain the lower triangular
5784 * band part of the matrix of coefficients, supplied column by
5785 * column, with the leading diagonal of the matrix in row 1 of
5786 * the array, the first sub-diagonal starting at position 1 in
5787 * row 2, and so on. The bottom right k by k triangle of the
5788 * array A is not referenced.
5789 * The following program segment will transfer a lower
5790 * triangular band matrix from conventional full matrix storage
5791 * to band storage:
5792 *
5793 * DO 20, J = 1, N
5794 * M = 1 - J
5795 * DO 10, I = J, MIN( N, J + K )
5796 * A( M + I, J ) = matrix( I, J )
5797 * 10 CONTINUE
5798 * 20 CONTINUE
5799 *
5800 * Note that when DIAG = 'U' or 'u' the elements of the array A
5801 * corresponding to the diagonal elements of the matrix are not
5802 * referenced, but are assumed to be unity.
5803 * Unchanged on exit.
5804 *
5805 * LDA - INTEGER.
5806 * On entry, LDA specifies the first dimension of A as declared
5807 * in the calling (sub) program. LDA must be at least
5808 * ( k + 1 ).
5809 * Unchanged on exit.
5810 *
5811 * X - COMPLEX array of dimension at least
5812 * ( 1 + ( n - 1 )*abs( INCX ) ).
5813 * Before entry, the incremented array X must contain the n
5814 * element right-hand side vector b. On exit, X is overwritten
5815 * with the solution vector x.
5816 *
5817 * INCX - INTEGER.
5818 * On entry, INCX specifies the increment for the elements of
5819 * X. INCX must not be zero.
5820 * Unchanged on exit.
5821 *
5822 *
5823 * Level 2 Blas routine.
5824 *
5825 * -- Written on 22-October-1986.
5826 * Jack Dongarra, Argonne National Lab.
5827 * Jeremy Du Croz, Nag Central Office.
5828 * Sven Hammarling, Nag Central Office.
5829 * Richard Hanson, Sandia National Labs.
5830 *
5831 *
5832 * .. Parameters ..
5833  COMPLEX ZERO
5834  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
5835 * .. Local Scalars ..
5836  COMPLEX TEMP
5837  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
5838  LOGICAL NOCONJ, NOUNIT
5839 * .. External Functions ..
5840  LOGICAL LSAME
5841  EXTERNAL lsame
5842 * .. External Subroutines ..
5843  EXTERNAL xerbla
5844 * .. Intrinsic Functions ..
5845  INTRINSIC conjg, max, min
5846 * ..
5847 * .. Executable Statements ..
5848 *
5849 * Test the input parameters.
5850 *
5851  info = 0
5852  IF ( .NOT.lsame( uplo , 'U' ).AND.
5853  $ .NOT.lsame( uplo , 'L' ) )THEN
5854  info = 1
5855  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
5856  $ .NOT.lsame( trans, 'T' ).AND.
5857  $ .NOT.lsame( trans, 'C' ) )THEN
5858  info = 2
5859  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
5860  $ .NOT.lsame( diag , 'N' ) )THEN
5861  info = 3
5862  ELSE IF( n.LT.0 )THEN
5863  info = 4
5864  ELSE IF( k.LT.0 )THEN
5865  info = 5
5866  ELSE IF( lda.LT.( k + 1 ) )THEN
5867  info = 7
5868  ELSE IF( incx.EQ.0 )THEN
5869  info = 9
5870  END IF
5871  IF( info.NE.0 )THEN
5872  CALL xerbla( 'CTBSV ', info )
5873  RETURN
5874  END IF
5875 *
5876 * Quick return if possible.
5877 *
5878  IF( n.EQ.0 )
5879  $ RETURN
5880 *
5881  noconj = lsame( trans, 'T' )
5882  nounit = lsame( diag , 'N' )
5883 *
5884 * Set up the start point in X if the increment is not unity. This
5885 * will be ( N - 1 )*INCX too small for descending loops.
5886 *
5887  IF( incx.LE.0 )THEN
5888  kx = 1 - ( n - 1 )*incx
5889  ELSE IF( incx.NE.1 )THEN
5890  kx = 1
5891  END IF
5892 *
5893 * Start the operations. In this version the elements of A are
5894 * accessed by sequentially with one pass through A.
5895 *
5896  IF( lsame( trans, 'N' ) )THEN
5897 *
5898 * Form x := inv( A )*x.
5899 *
5900  IF( lsame( uplo, 'U' ) )THEN
5901  kplus1 = k + 1
5902  IF( incx.EQ.1 )THEN
5903  DO 20, j = n, 1, -1
5904  IF( x( j ).NE.zero )THEN
5905  l = kplus1 - j
5906  IF( nounit )
5907  $ x( j ) = x( j )/a( kplus1, j )
5908  temp = x( j )
5909  DO 10, i = j - 1, max( 1, j - k ), -1
5910  x( i ) = x( i ) - temp*a( l + i, j )
5911  10 CONTINUE
5912  END IF
5913  20 CONTINUE
5914  ELSE
5915  kx = kx + ( n - 1 )*incx
5916  jx = kx
5917  DO 40, j = n, 1, -1
5918  kx = kx - incx
5919  IF( x( jx ).NE.zero )THEN
5920  ix = kx
5921  l = kplus1 - j
5922  IF( nounit )
5923  $ x( jx ) = x( jx )/a( kplus1, j )
5924  temp = x( jx )
5925  DO 30, i = j - 1, max( 1, j - k ), -1
5926  x( ix ) = x( ix ) - temp*a( l + i, j )
5927  ix = ix - incx
5928  30 CONTINUE
5929  END IF
5930  jx = jx - incx
5931  40 CONTINUE
5932  END IF
5933  ELSE
5934  IF( incx.EQ.1 )THEN
5935  DO 60, j = 1, n
5936  IF( x( j ).NE.zero )THEN
5937  l = 1 - j
5938  IF( nounit )
5939  $ x( j ) = x( j )/a( 1, j )
5940  temp = x( j )
5941  DO 50, i = j + 1, min( n, j + k )
5942  x( i ) = x( i ) - temp*a( l + i, j )
5943  50 CONTINUE
5944  END IF
5945  60 CONTINUE
5946  ELSE
5947  jx = kx
5948  DO 80, j = 1, n
5949  kx = kx + incx
5950  IF( x( jx ).NE.zero )THEN
5951  ix = kx
5952  l = 1 - j
5953  IF( nounit )
5954  $ x( jx ) = x( jx )/a( 1, j )
5955  temp = x( jx )
5956  DO 70, i = j + 1, min( n, j + k )
5957  x( ix ) = x( ix ) - temp*a( l + i, j )
5958  ix = ix + incx
5959  70 CONTINUE
5960  END IF
5961  jx = jx + incx
5962  80 CONTINUE
5963  END IF
5964  END IF
5965  ELSE
5966 *
5967 * Form x := inv( A' )*x or x := inv( conjg( A') )*x.
5968 *
5969  IF( lsame( uplo, 'U' ) )THEN
5970  kplus1 = k + 1
5971  IF( incx.EQ.1 )THEN
5972  DO 110, j = 1, n
5973  temp = x( j )
5974  l = kplus1 - j
5975  IF( noconj )THEN
5976  DO 90, i = max( 1, j - k ), j - 1
5977  temp = temp - a( l + i, j )*x( i )
5978  90 CONTINUE
5979  IF( nounit )
5980  $ temp = temp/a( kplus1, j )
5981  ELSE
5982  DO 100, i = max( 1, j - k ), j - 1
5983  temp = temp - conjg( a( l + i, j ) )*x( i )
5984  100 CONTINUE
5985  IF( nounit )
5986  $ temp = temp/conjg( a( kplus1, j ) )
5987  END IF
5988  x( j ) = temp
5989  110 CONTINUE
5990  ELSE
5991  jx = kx
5992  DO 140, j = 1, n
5993  temp = x( jx )
5994  ix = kx
5995  l = kplus1 - j
5996  IF( noconj )THEN
5997  DO 120, i = max( 1, j - k ), j - 1
5998  temp = temp - a( l + i, j )*x( ix )
5999  ix = ix + incx
6000  120 CONTINUE
6001  IF( nounit )
6002  $ temp = temp/a( kplus1, j )
6003  ELSE
6004  DO 130, i = max( 1, j - k ), j - 1
6005  temp = temp - conjg( a( l + i, j ) )*x( ix )
6006  ix = ix + incx
6007  130 CONTINUE
6008  IF( nounit )
6009  $ temp = temp/conjg( a( kplus1, j ) )
6010  END IF
6011  x( jx ) = temp
6012  jx = jx + incx
6013  IF( j.GT.k )
6014  $ kx = kx + incx
6015  140 CONTINUE
6016  END IF
6017  ELSE
6018  IF( incx.EQ.1 )THEN
6019  DO 170, j = n, 1, -1
6020  temp = x( j )
6021  l = 1 - j
6022  IF( noconj )THEN
6023  DO 150, i = min( n, j + k ), j + 1, -1
6024  temp = temp - a( l + i, j )*x( i )
6025  150 CONTINUE
6026  IF( nounit )
6027  $ temp = temp/a( 1, j )
6028  ELSE
6029  DO 160, i = min( n, j + k ), j + 1, -1
6030  temp = temp - conjg( a( l + i, j ) )*x( i )
6031  160 CONTINUE
6032  IF( nounit )
6033  $ temp = temp/conjg( a( 1, j ) )
6034  END IF
6035  x( j ) = temp
6036  170 CONTINUE
6037  ELSE
6038  kx = kx + ( n - 1 )*incx
6039  jx = kx
6040  DO 200, j = n, 1, -1
6041  temp = x( jx )
6042  ix = kx
6043  l = 1 - j
6044  IF( noconj )THEN
6045  DO 180, i = min( n, j + k ), j + 1, -1
6046  temp = temp - a( l + i, j )*x( ix )
6047  ix = ix - incx
6048  180 CONTINUE
6049  IF( nounit )
6050  $ temp = temp/a( 1, j )
6051  ELSE
6052  DO 190, i = min( n, j + k ), j + 1, -1
6053  temp = temp - conjg( a( l + i, j ) )*x( ix )
6054  ix = ix - incx
6055  190 CONTINUE
6056  IF( nounit )
6057  $ temp = temp/conjg( a( 1, j ) )
6058  END IF
6059  x( jx ) = temp
6060  jx = jx - incx
6061  IF( ( n - j ).GE.k )
6062  $ kx = kx - incx
6063  200 CONTINUE
6064  END IF
6065  END IF
6066  END IF
6067 *
6068  RETURN
6069 *
6070 * End of CTBSV .
6071 *
6072  END
6073  SUBROUTINE ctpmv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
6074 * .. Scalar Arguments ..
6075  INTEGER INCX, N
6076  CHARACTER*1 DIAG, TRANS, UPLO
6077 * .. Array Arguments ..
6078  COMPLEX AP( * ), X( * )
6079 * ..
6080 *
6081 * Purpose
6082 * =======
6083 *
6084 * CTPMV performs one of the matrix-vector operations
6085 *
6086 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
6087 *
6088 * where x is an n element vector and A is an n by n unit, or non-unit,
6089 * upper or lower triangular matrix, supplied in packed form.
6090 *
6091 * Parameters
6092 * ==========
6093 *
6094 * UPLO - CHARACTER*1.
6095 * On entry, UPLO specifies whether the matrix is an upper or
6096 * lower triangular matrix as follows:
6097 *
6098 * UPLO = 'U' or 'u' A is an upper triangular matrix.
6099 *
6100 * UPLO = 'L' or 'l' A is a lower triangular matrix.
6101 *
6102 * Unchanged on exit.
6103 *
6104 * TRANS - CHARACTER*1.
6105 * On entry, TRANS specifies the operation to be performed as
6106 * follows:
6107 *
6108 * TRANS = 'N' or 'n' x := A*x.
6109 *
6110 * TRANS = 'T' or 't' x := A'*x.
6111 *
6112 * TRANS = 'C' or 'c' x := conjg( A' )*x.
6113 *
6114 * Unchanged on exit.
6115 *
6116 * DIAG - CHARACTER*1.
6117 * On entry, DIAG specifies whether or not A is unit
6118 * triangular as follows:
6119 *
6120 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
6121 *
6122 * DIAG = 'N' or 'n' A is not assumed to be unit
6123 * triangular.
6124 *
6125 * Unchanged on exit.
6126 *
6127 * N - INTEGER.
6128 * On entry, N specifies the order of the matrix A.
6129 * N must be at least zero.
6130 * Unchanged on exit.
6131 *
6132 * AP - COMPLEX array of DIMENSION at least
6133 * ( ( n*( n + 1 ) )/2 ).
6134 * Before entry with UPLO = 'U' or 'u', the array AP must
6135 * contain the upper triangular matrix packed sequentially,
6136 * column by column, so that AP( 1 ) contains a( 1, 1 ),
6137 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
6138 * respectively, and so on.
6139 * Before entry with UPLO = 'L' or 'l', the array AP must
6140 * contain the lower triangular matrix packed sequentially,
6141 * column by column, so that AP( 1 ) contains a( 1, 1 ),
6142 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
6143 * respectively, and so on.
6144 * Note that when DIAG = 'U' or 'u', the diagonal elements of
6145 * A are not referenced, but are assumed to be unity.
6146 * Unchanged on exit.
6147 *
6148 * X - COMPLEX array of dimension at least
6149 * ( 1 + ( n - 1 )*abs( INCX ) ).
6150 * Before entry, the incremented array X must contain the n
6151 * element vector x. On exit, X is overwritten with the
6152 * tranformed vector x.
6153 *
6154 * INCX - INTEGER.
6155 * On entry, INCX specifies the increment for the elements of
6156 * X. INCX must not be zero.
6157 * Unchanged on exit.
6158 *
6159 *
6160 * Level 2 Blas routine.
6161 *
6162 * -- Written on 22-October-1986.
6163 * Jack Dongarra, Argonne National Lab.
6164 * Jeremy Du Croz, Nag Central Office.
6165 * Sven Hammarling, Nag Central Office.
6166 * Richard Hanson, Sandia National Labs.
6167 *
6168 *
6169 * .. Parameters ..
6170  COMPLEX ZERO
6171  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
6172 * .. Local Scalars ..
6173  COMPLEX TEMP
6174  INTEGER I, INFO, IX, J, JX, K, KK, KX
6175  LOGICAL NOCONJ, NOUNIT
6176 * .. External Functions ..
6177  LOGICAL LSAME
6178  EXTERNAL lsame
6179 * .. External Subroutines ..
6180  EXTERNAL xerbla
6181 * .. Intrinsic Functions ..
6182  INTRINSIC conjg
6183 * ..
6184 * .. Executable Statements ..
6185 *
6186 * Test the input parameters.
6187 *
6188  info = 0
6189  IF ( .NOT.lsame( uplo , 'U' ).AND.
6190  $ .NOT.lsame( uplo , 'L' ) )THEN
6191  info = 1
6192  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
6193  $ .NOT.lsame( trans, 'T' ).AND.
6194  $ .NOT.lsame( trans, 'C' ) )THEN
6195  info = 2
6196  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
6197  $ .NOT.lsame( diag , 'N' ) )THEN
6198  info = 3
6199  ELSE IF( n.LT.0 )THEN
6200  info = 4
6201  ELSE IF( incx.EQ.0 )THEN
6202  info = 7
6203  END IF
6204  IF( info.NE.0 )THEN
6205  CALL xerbla( 'CTPMV ', info )
6206  RETURN
6207  END IF
6208 *
6209 * Quick return if possible.
6210 *
6211  IF( n.EQ.0 )
6212  $ RETURN
6213 *
6214  noconj = lsame( trans, 'T' )
6215  nounit = lsame( diag , 'N' )
6216 *
6217 * Set up the start point in X if the increment is not unity. This
6218 * will be ( N - 1 )*INCX too small for descending loops.
6219 *
6220  IF( incx.LE.0 )THEN
6221  kx = 1 - ( n - 1 )*incx
6222  ELSE IF( incx.NE.1 )THEN
6223  kx = 1
6224  END IF
6225 *
6226 * Start the operations. In this version the elements of AP are
6227 * accessed sequentially with one pass through AP.
6228 *
6229  IF( lsame( trans, 'N' ) )THEN
6230 *
6231 * Form x:= A*x.
6232 *
6233  IF( lsame( uplo, 'U' ) )THEN
6234  kk = 1
6235  IF( incx.EQ.1 )THEN
6236  DO 20, j = 1, n
6237  IF( x( j ).NE.zero )THEN
6238  temp = x( j )
6239  k = kk
6240  DO 10, i = 1, j - 1
6241  x( i ) = x( i ) + temp*ap( k )
6242  k = k + 1
6243  10 CONTINUE
6244  IF( nounit )
6245  $ x( j ) = x( j )*ap( kk + j - 1 )
6246  END IF
6247  kk = kk + j
6248  20 CONTINUE
6249  ELSE
6250  jx = kx
6251  DO 40, j = 1, n
6252  IF( x( jx ).NE.zero )THEN
6253  temp = x( jx )
6254  ix = kx
6255  DO 30, k = kk, kk + j - 2
6256  x( ix ) = x( ix ) + temp*ap( k )
6257  ix = ix + incx
6258  30 CONTINUE
6259  IF( nounit )
6260  $ x( jx ) = x( jx )*ap( kk + j - 1 )
6261  END IF
6262  jx = jx + incx
6263  kk = kk + j
6264  40 CONTINUE
6265  END IF
6266  ELSE
6267  kk = ( n*( n + 1 ) )/2
6268  IF( incx.EQ.1 )THEN
6269  DO 60, j = n, 1, -1
6270  IF( x( j ).NE.zero )THEN
6271  temp = x( j )
6272  k = kk
6273  DO 50, i = n, j + 1, -1
6274  x( i ) = x( i ) + temp*ap( k )
6275  k = k - 1
6276  50 CONTINUE
6277  IF( nounit )
6278  $ x( j ) = x( j )*ap( kk - n + j )
6279  END IF
6280  kk = kk - ( n - j + 1 )
6281  60 CONTINUE
6282  ELSE
6283  kx = kx + ( n - 1 )*incx
6284  jx = kx
6285  DO 80, j = n, 1, -1
6286  IF( x( jx ).NE.zero )THEN
6287  temp = x( jx )
6288  ix = kx
6289  DO 70, k = kk, kk - ( n - ( j + 1 ) ), -1
6290  x( ix ) = x( ix ) + temp*ap( k )
6291  ix = ix - incx
6292  70 CONTINUE
6293  IF( nounit )
6294  $ x( jx ) = x( jx )*ap( kk - n + j )
6295  END IF
6296  jx = jx - incx
6297  kk = kk - ( n - j + 1 )
6298  80 CONTINUE
6299  END IF
6300  END IF
6301  ELSE
6302 *
6303 * Form x := A'*x or x := conjg( A' )*x.
6304 *
6305  IF( lsame( uplo, 'U' ) )THEN
6306  kk = ( n*( n + 1 ) )/2
6307  IF( incx.EQ.1 )THEN
6308  DO 110, j = n, 1, -1
6309  temp = x( j )
6310  k = kk - 1
6311  IF( noconj )THEN
6312  IF( nounit )
6313  $ temp = temp*ap( kk )
6314  DO 90, i = j - 1, 1, -1
6315  temp = temp + ap( k )*x( i )
6316  k = k - 1
6317  90 CONTINUE
6318  ELSE
6319  IF( nounit )
6320  $ temp = temp*conjg( ap( kk ) )
6321  DO 100, i = j - 1, 1, -1
6322  temp = temp + conjg( ap( k ) )*x( i )
6323  k = k - 1
6324  100 CONTINUE
6325  END IF
6326  x( j ) = temp
6327  kk = kk - j
6328  110 CONTINUE
6329  ELSE
6330  jx = kx + ( n - 1 )*incx
6331  DO 140, j = n, 1, -1
6332  temp = x( jx )
6333  ix = jx
6334  IF( noconj )THEN
6335  IF( nounit )
6336  $ temp = temp*ap( kk )
6337  DO 120, k = kk - 1, kk - j + 1, -1
6338  ix = ix - incx
6339  temp = temp + ap( k )*x( ix )
6340  120 CONTINUE
6341  ELSE
6342  IF( nounit )
6343  $ temp = temp*conjg( ap( kk ) )
6344  DO 130, k = kk - 1, kk - j + 1, -1
6345  ix = ix - incx
6346  temp = temp + conjg( ap( k ) )*x( ix )
6347  130 CONTINUE
6348  END IF
6349  x( jx ) = temp
6350  jx = jx - incx
6351  kk = kk - j
6352  140 CONTINUE
6353  END IF
6354  ELSE
6355  kk = 1
6356  IF( incx.EQ.1 )THEN
6357  DO 170, j = 1, n
6358  temp = x( j )
6359  k = kk + 1
6360  IF( noconj )THEN
6361  IF( nounit )
6362  $ temp = temp*ap( kk )
6363  DO 150, i = j + 1, n
6364  temp = temp + ap( k )*x( i )
6365  k = k + 1
6366  150 CONTINUE
6367  ELSE
6368  IF( nounit )
6369  $ temp = temp*conjg( ap( kk ) )
6370  DO 160, i = j + 1, n
6371  temp = temp + conjg( ap( k ) )*x( i )
6372  k = k + 1
6373  160 CONTINUE
6374  END IF
6375  x( j ) = temp
6376  kk = kk + ( n - j + 1 )
6377  170 CONTINUE
6378  ELSE
6379  jx = kx
6380  DO 200, j = 1, n
6381  temp = x( jx )
6382  ix = jx
6383  IF( noconj )THEN
6384  IF( nounit )
6385  $ temp = temp*ap( kk )
6386  DO 180, k = kk + 1, kk + n - j
6387  ix = ix + incx
6388  temp = temp + ap( k )*x( ix )
6389  180 CONTINUE
6390  ELSE
6391  IF( nounit )
6392  $ temp = temp*conjg( ap( kk ) )
6393  DO 190, k = kk + 1, kk + n - j
6394  ix = ix + incx
6395  temp = temp + conjg( ap( k ) )*x( ix )
6396  190 CONTINUE
6397  END IF
6398  x( jx ) = temp
6399  jx = jx + incx
6400  kk = kk + ( n - j + 1 )
6401  200 CONTINUE
6402  END IF
6403  END IF
6404  END IF
6405 *
6406  RETURN
6407 *
6408 * End of CTPMV .
6409 *
6410  END
6411  SUBROUTINE ctpsv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
6412 * .. Scalar Arguments ..
6413  INTEGER INCX, N
6414  CHARACTER*1 DIAG, TRANS, UPLO
6415 * .. Array Arguments ..
6416  COMPLEX AP( * ), X( * )
6417 * ..
6418 *
6419 * Purpose
6420 * =======
6421 *
6422 * CTPSV solves one of the systems of equations
6423 *
6424 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
6425 *
6426 * where b and x are n element vectors and A is an n by n unit, or
6427 * non-unit, upper or lower triangular matrix, supplied in packed form.
6428 *
6429 * No test for singularity or near-singularity is included in this
6430 * routine. Such tests must be performed before calling this routine.
6431 *
6432 * Parameters
6433 * ==========
6434 *
6435 * UPLO - CHARACTER*1.
6436 * On entry, UPLO specifies whether the matrix is an upper or
6437 * lower triangular matrix as follows:
6438 *
6439 * UPLO = 'U' or 'u' A is an upper triangular matrix.
6440 *
6441 * UPLO = 'L' or 'l' A is a lower triangular matrix.
6442 *
6443 * Unchanged on exit.
6444 *
6445 * TRANS - CHARACTER*1.
6446 * On entry, TRANS specifies the equations to be solved as
6447 * follows:
6448 *
6449 * TRANS = 'N' or 'n' A*x = b.
6450 *
6451 * TRANS = 'T' or 't' A'*x = b.
6452 *
6453 * TRANS = 'C' or 'c' conjg( A' )*x = b.
6454 *
6455 * Unchanged on exit.
6456 *
6457 * DIAG - CHARACTER*1.
6458 * On entry, DIAG specifies whether or not A is unit
6459 * triangular as follows:
6460 *
6461 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
6462 *
6463 * DIAG = 'N' or 'n' A is not assumed to be unit
6464 * triangular.
6465 *
6466 * Unchanged on exit.
6467 *
6468 * N - INTEGER.
6469 * On entry, N specifies the order of the matrix A.
6470 * N must be at least zero.
6471 * Unchanged on exit.
6472 *
6473 * AP - COMPLEX array of DIMENSION at least
6474 * ( ( n*( n + 1 ) )/2 ).
6475 * Before entry with UPLO = 'U' or 'u', the array AP must
6476 * contain the upper triangular matrix packed sequentially,
6477 * column by column, so that AP( 1 ) contains a( 1, 1 ),
6478 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
6479 * respectively, and so on.
6480 * Before entry with UPLO = 'L' or 'l', the array AP must
6481 * contain the lower triangular matrix packed sequentially,
6482 * column by column, so that AP( 1 ) contains a( 1, 1 ),
6483 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
6484 * respectively, and so on.
6485 * Note that when DIAG = 'U' or 'u', the diagonal elements of
6486 * A are not referenced, but are assumed to be unity.
6487 * Unchanged on exit.
6488 *
6489 * X - COMPLEX array of dimension at least
6490 * ( 1 + ( n - 1 )*abs( INCX ) ).
6491 * Before entry, the incremented array X must contain the n
6492 * element right-hand side vector b. On exit, X is overwritten
6493 * with the solution vector x.
6494 *
6495 * INCX - INTEGER.
6496 * On entry, INCX specifies the increment for the elements of
6497 * X. INCX must not be zero.
6498 * Unchanged on exit.
6499 *
6500 *
6501 * Level 2 Blas routine.
6502 *
6503 * -- Written on 22-October-1986.
6504 * Jack Dongarra, Argonne National Lab.
6505 * Jeremy Du Croz, Nag Central Office.
6506 * Sven Hammarling, Nag Central Office.
6507 * Richard Hanson, Sandia National Labs.
6508 *
6509 *
6510 * .. Parameters ..
6511  COMPLEX ZERO
6512  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
6513 * .. Local Scalars ..
6514  COMPLEX TEMP
6515  INTEGER I, INFO, IX, J, JX, K, KK, KX
6516  LOGICAL NOCONJ, NOUNIT
6517 * .. External Functions ..
6518  LOGICAL LSAME
6519  EXTERNAL lsame
6520 * .. External Subroutines ..
6521  EXTERNAL xerbla
6522 * .. Intrinsic Functions ..
6523  INTRINSIC conjg
6524 * ..
6525 * .. Executable Statements ..
6526 *
6527 * Test the input parameters.
6528 *
6529  info = 0
6530  IF ( .NOT.lsame( uplo , 'U' ).AND.
6531  $ .NOT.lsame( uplo , 'L' ) )THEN
6532  info = 1
6533  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
6534  $ .NOT.lsame( trans, 'T' ).AND.
6535  $ .NOT.lsame( trans, 'C' ) )THEN
6536  info = 2
6537  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
6538  $ .NOT.lsame( diag , 'N' ) )THEN
6539  info = 3
6540  ELSE IF( n.LT.0 )THEN
6541  info = 4
6542  ELSE IF( incx.EQ.0 )THEN
6543  info = 7
6544  END IF
6545  IF( info.NE.0 )THEN
6546  CALL xerbla( 'CTPSV ', info )
6547  RETURN
6548  END IF
6549 *
6550 * Quick return if possible.
6551 *
6552  IF( n.EQ.0 )
6553  $ RETURN
6554 *
6555  noconj = lsame( trans, 'T' )
6556  nounit = lsame( diag , 'N' )
6557 *
6558 * Set up the start point in X if the increment is not unity. This
6559 * will be ( N - 1 )*INCX too small for descending loops.
6560 *
6561  IF( incx.LE.0 )THEN
6562  kx = 1 - ( n - 1 )*incx
6563  ELSE IF( incx.NE.1 )THEN
6564  kx = 1
6565  END IF
6566 *
6567 * Start the operations. In this version the elements of AP are
6568 * accessed sequentially with one pass through AP.
6569 *
6570  IF( lsame( trans, 'N' ) )THEN
6571 *
6572 * Form x := inv( A )*x.
6573 *
6574  IF( lsame( uplo, 'U' ) )THEN
6575  kk = ( n*( n + 1 ) )/2
6576  IF( incx.EQ.1 )THEN
6577  DO 20, j = n, 1, -1
6578  IF( x( j ).NE.zero )THEN
6579  IF( nounit )
6580  $ x( j ) = x( j )/ap( kk )
6581  temp = x( j )
6582  k = kk - 1
6583  DO 10, i = j - 1, 1, -1
6584  x( i ) = x( i ) - temp*ap( k )
6585  k = k - 1
6586  10 CONTINUE
6587  END IF
6588  kk = kk - j
6589  20 CONTINUE
6590  ELSE
6591  jx = kx + ( n - 1 )*incx
6592  DO 40, j = n, 1, -1
6593  IF( x( jx ).NE.zero )THEN
6594  IF( nounit )
6595  $ x( jx ) = x( jx )/ap( kk )
6596  temp = x( jx )
6597  ix = jx
6598  DO 30, k = kk - 1, kk - j + 1, -1
6599  ix = ix - incx
6600  x( ix ) = x( ix ) - temp*ap( k )
6601  30 CONTINUE
6602  END IF
6603  jx = jx - incx
6604  kk = kk - j
6605  40 CONTINUE
6606  END IF
6607  ELSE
6608  kk = 1
6609  IF( incx.EQ.1 )THEN
6610  DO 60, j = 1, n
6611  IF( x( j ).NE.zero )THEN
6612  IF( nounit )
6613  $ x( j ) = x( j )/ap( kk )
6614  temp = x( j )
6615  k = kk + 1
6616  DO 50, i = j + 1, n
6617  x( i ) = x( i ) - temp*ap( k )
6618  k = k + 1
6619  50 CONTINUE
6620  END IF
6621  kk = kk + ( n - j + 1 )
6622  60 CONTINUE
6623  ELSE
6624  jx = kx
6625  DO 80, j = 1, n
6626  IF( x( jx ).NE.zero )THEN
6627  IF( nounit )
6628  $ x( jx ) = x( jx )/ap( kk )
6629  temp = x( jx )
6630  ix = jx
6631  DO 70, k = kk + 1, kk + n - j
6632  ix = ix + incx
6633  x( ix ) = x( ix ) - temp*ap( k )
6634  70 CONTINUE
6635  END IF
6636  jx = jx + incx
6637  kk = kk + ( n - j + 1 )
6638  80 CONTINUE
6639  END IF
6640  END IF
6641  ELSE
6642 *
6643 * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x.
6644 *
6645  IF( lsame( uplo, 'U' ) )THEN
6646  kk = 1
6647  IF( incx.EQ.1 )THEN
6648  DO 110, j = 1, n
6649  temp = x( j )
6650  k = kk
6651  IF( noconj )THEN
6652  DO 90, i = 1, j - 1
6653  temp = temp - ap( k )*x( i )
6654  k = k + 1
6655  90 CONTINUE
6656  IF( nounit )
6657  $ temp = temp/ap( kk + j - 1 )
6658  ELSE
6659  DO 100, i = 1, j - 1
6660  temp = temp - conjg( ap( k ) )*x( i )
6661  k = k + 1
6662  100 CONTINUE
6663  IF( nounit )
6664  $ temp = temp/conjg( ap( kk + j - 1 ) )
6665  END IF
6666  x( j ) = temp
6667  kk = kk + j
6668  110 CONTINUE
6669  ELSE
6670  jx = kx
6671  DO 140, j = 1, n
6672  temp = x( jx )
6673  ix = kx
6674  IF( noconj )THEN
6675  DO 120, k = kk, kk + j - 2
6676  temp = temp - ap( k )*x( ix )
6677  ix = ix + incx
6678  120 CONTINUE
6679  IF( nounit )
6680  $ temp = temp/ap( kk + j - 1 )
6681  ELSE
6682  DO 130, k = kk, kk + j - 2
6683  temp = temp - conjg( ap( k ) )*x( ix )
6684  ix = ix + incx
6685  130 CONTINUE
6686  IF( nounit )
6687  $ temp = temp/conjg( ap( kk + j - 1 ) )
6688  END IF
6689  x( jx ) = temp
6690  jx = jx + incx
6691  kk = kk + j
6692  140 CONTINUE
6693  END IF
6694  ELSE
6695  kk = ( n*( n + 1 ) )/2
6696  IF( incx.EQ.1 )THEN
6697  DO 170, j = n, 1, -1
6698  temp = x( j )
6699  k = kk
6700  IF( noconj )THEN
6701  DO 150, i = n, j + 1, -1
6702  temp = temp - ap( k )*x( i )
6703  k = k - 1
6704  150 CONTINUE
6705  IF( nounit )
6706  $ temp = temp/ap( kk - n + j )
6707  ELSE
6708  DO 160, i = n, j + 1, -1
6709  temp = temp - conjg( ap( k ) )*x( i )
6710  k = k - 1
6711  160 CONTINUE
6712  IF( nounit )
6713  $ temp = temp/conjg( ap( kk - n + j ) )
6714  END IF
6715  x( j ) = temp
6716  kk = kk - ( n - j + 1 )
6717  170 CONTINUE
6718  ELSE
6719  kx = kx + ( n - 1 )*incx
6720  jx = kx
6721  DO 200, j = n, 1, -1
6722  temp = x( jx )
6723  ix = kx
6724  IF( noconj )THEN
6725  DO 180, k = kk, kk - ( n - ( j + 1 ) ), -1
6726  temp = temp - ap( k )*x( ix )
6727  ix = ix - incx
6728  180 CONTINUE
6729  IF( nounit )
6730  $ temp = temp/ap( kk - n + j )
6731  ELSE
6732  DO 190, k = kk, kk - ( n - ( j + 1 ) ), -1
6733  temp = temp - conjg( ap( k ) )*x( ix )
6734  ix = ix - incx
6735  190 CONTINUE
6736  IF( nounit )
6737  $ temp = temp/conjg( ap( kk - n + j ) )
6738  END IF
6739  x( jx ) = temp
6740  jx = jx - incx
6741  kk = kk - ( n - j + 1 )
6742  200 CONTINUE
6743  END IF
6744  END IF
6745  END IF
6746 *
6747  RETURN
6748 *
6749 * End of CTPSV .
6750 *
6751  END
6752  SUBROUTINE ctrmm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
6753  $ b, ldb )
6754 * .. Scalar Arguments ..
6755  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
6756  INTEGER M, N, LDA, LDB
6757  COMPLEX ALPHA
6758 * .. Array Arguments ..
6759  COMPLEX A( lda, * ), B( ldb, * )
6760 * ..
6761 *
6762 * Purpose
6763 * =======
6764 *
6765 * CTRMM performs one of the matrix-matrix operations
6766 *
6767 * B := alpha*op( A )*B, or B := alpha*B*op( A )
6768 *
6769 * where alpha is a scalar, B is an m by n matrix, A is a unit, or
6770 * non-unit, upper or lower triangular matrix and op( A ) is one of
6771 *
6772 * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
6773 *
6774 * Parameters
6775 * ==========
6776 *
6777 * SIDE - CHARACTER*1.
6778 * On entry, SIDE specifies whether op( A ) multiplies B from
6779 * the left or right as follows:
6780 *
6781 * SIDE = 'L' or 'l' B := alpha*op( A )*B.
6782 *
6783 * SIDE = 'R' or 'r' B := alpha*B*op( A ).
6784 *
6785 * Unchanged on exit.
6786 *
6787 * UPLO - CHARACTER*1.
6788 * On entry, UPLO specifies whether the matrix A is an upper or
6789 * lower triangular matrix as follows:
6790 *
6791 * UPLO = 'U' or 'u' A is an upper triangular matrix.
6792 *
6793 * UPLO = 'L' or 'l' A is a lower triangular matrix.
6794 *
6795 * Unchanged on exit.
6796 *
6797 * TRANSA - CHARACTER*1.
6798 * On entry, TRANSA specifies the form of op( A ) to be used in
6799 * the matrix multiplication as follows:
6800 *
6801 * TRANSA = 'N' or 'n' op( A ) = A.
6802 *
6803 * TRANSA = 'T' or 't' op( A ) = A'.
6804 *
6805 * TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
6806 *
6807 * Unchanged on exit.
6808 *
6809 * DIAG - CHARACTER*1.
6810 * On entry, DIAG specifies whether or not A is unit triangular
6811 * as follows:
6812 *
6813 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
6814 *
6815 * DIAG = 'N' or 'n' A is not assumed to be unit
6816 * triangular.
6817 *
6818 * Unchanged on exit.
6819 *
6820 * M - INTEGER.
6821 * On entry, M specifies the number of rows of B. M must be at
6822 * least zero.
6823 * Unchanged on exit.
6824 *
6825 * N - INTEGER.
6826 * On entry, N specifies the number of columns of B. N must be
6827 * at least zero.
6828 * Unchanged on exit.
6829 *
6830 * ALPHA - COMPLEX .
6831 * On entry, ALPHA specifies the scalar alpha. When alpha is
6832 * zero then A is not referenced and B need not be set before
6833 * entry.
6834 * Unchanged on exit.
6835 *
6836 * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m
6837 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
6838 * Before entry with UPLO = 'U' or 'u', the leading k by k
6839 * upper triangular part of the array A must contain the upper
6840 * triangular matrix and the strictly lower triangular part of
6841 * A is not referenced.
6842 * Before entry with UPLO = 'L' or 'l', the leading k by k
6843 * lower triangular part of the array A must contain the lower
6844 * triangular matrix and the strictly upper triangular part of
6845 * A is not referenced.
6846 * Note that when DIAG = 'U' or 'u', the diagonal elements of
6847 * A are not referenced either, but are assumed to be unity.
6848 * Unchanged on exit.
6849 *
6850 * LDA - INTEGER.
6851 * On entry, LDA specifies the first dimension of A as declared
6852 * in the calling (sub) program. When SIDE = 'L' or 'l' then
6853 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
6854 * then LDA must be at least max( 1, n ).
6855 * Unchanged on exit.
6856 *
6857 * B - COMPLEX array of DIMENSION ( LDB, n ).
6858 * Before entry, the leading m by n part of the array B must
6859 * contain the matrix B, and on exit is overwritten by the
6860 * transformed matrix.
6861 *
6862 * LDB - INTEGER.
6863 * On entry, LDB specifies the first dimension of B as declared
6864 * in the calling (sub) program. LDB must be at least
6865 * max( 1, m ).
6866 * Unchanged on exit.
6867 *
6868 *
6869 * Level 3 Blas routine.
6870 *
6871 * -- Written on 8-February-1989.
6872 * Jack Dongarra, Argonne National Laboratory.
6873 * Iain Duff, AERE Harwell.
6874 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
6875 * Sven Hammarling, Numerical Algorithms Group Ltd.
6876 *
6877 *
6878 * .. External Functions ..
6879  LOGICAL LSAME
6880  EXTERNAL lsame
6881 * .. External Subroutines ..
6882  EXTERNAL xerbla
6883 * .. Intrinsic Functions ..
6884  INTRINSIC conjg, max
6885 * .. Local Scalars ..
6886  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
6887  INTEGER I, INFO, J, K, NROWA
6888  COMPLEX TEMP
6889 * .. Parameters ..
6890  COMPLEX ONE
6891  parameter( one = ( 1.0e+0, 0.0e+0 ) )
6892  COMPLEX ZERO
6893  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
6894 * ..
6895 * .. Executable Statements ..
6896 *
6897 * Test the input parameters.
6898 *
6899  lside = lsame( side , 'L' )
6900  IF( lside )THEN
6901  nrowa = m
6902  ELSE
6903  nrowa = n
6904  END IF
6905  noconj = lsame( transa, 'T' )
6906  nounit = lsame( diag , 'N' )
6907  upper = lsame( uplo , 'U' )
6908 *
6909  info = 0
6910  IF( ( .NOT.lside ).AND.
6911  $ ( .NOT.lsame( side , 'R' ) ) )THEN
6912  info = 1
6913  ELSE IF( ( .NOT.upper ).AND.
6914  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
6915  info = 2
6916  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
6917  $ ( .NOT.lsame( transa, 'T' ) ).AND.
6918  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
6919  info = 3
6920  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
6921  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
6922  info = 4
6923  ELSE IF( m .LT.0 )THEN
6924  info = 5
6925  ELSE IF( n .LT.0 )THEN
6926  info = 6
6927  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
6928  info = 9
6929  ELSE IF( ldb.LT.max( 1, m ) )THEN
6930  info = 11
6931  END IF
6932  IF( info.NE.0 )THEN
6933  CALL xerbla( 'CTRMM ', info )
6934  RETURN
6935  END IF
6936 *
6937 * Quick return if possible.
6938 *
6939  IF( n.EQ.0 )
6940  $ RETURN
6941 *
6942 * And when alpha.eq.zero.
6943 *
6944  IF( alpha.EQ.zero )THEN
6945  DO 20, j = 1, n
6946  DO 10, i = 1, m
6947  b( i, j ) = zero
6948  10 CONTINUE
6949  20 CONTINUE
6950  RETURN
6951  END IF
6952 *
6953 * Start the operations.
6954 *
6955  IF( lside )THEN
6956  IF( lsame( transa, 'N' ) )THEN
6957 *
6958 * Form B := alpha*A*B.
6959 *
6960  IF( upper )THEN
6961  DO 50, j = 1, n
6962  DO 40, k = 1, m
6963  IF( b( k, j ).NE.zero )THEN
6964  temp = alpha*b( k, j )
6965  DO 30, i = 1, k - 1
6966  b( i, j ) = b( i, j ) + temp*a( i, k )
6967  30 CONTINUE
6968  IF( nounit )
6969  $ temp = temp*a( k, k )
6970  b( k, j ) = temp
6971  END IF
6972  40 CONTINUE
6973  50 CONTINUE
6974  ELSE
6975  DO 80, j = 1, n
6976  DO 70 k = m, 1, -1
6977  IF( b( k, j ).NE.zero )THEN
6978  temp = alpha*b( k, j )
6979  b( k, j ) = temp
6980  IF( nounit )
6981  $ b( k, j ) = b( k, j )*a( k, k )
6982  DO 60, i = k + 1, m
6983  b( i, j ) = b( i, j ) + temp*a( i, k )
6984  60 CONTINUE
6985  END IF
6986  70 CONTINUE
6987  80 CONTINUE
6988  END IF
6989  ELSE
6990 *
6991 * Form B := alpha*A'*B or B := alpha*conjg( A' )*B.
6992 *
6993  IF( upper )THEN
6994  DO 120, j = 1, n
6995  DO 110, i = m, 1, -1
6996  temp = b( i, j )
6997  IF( noconj )THEN
6998  IF( nounit )
6999  $ temp = temp*a( i, i )
7000  DO 90, k = 1, i - 1
7001  temp = temp + a( k, i )*b( k, j )
7002  90 CONTINUE
7003  ELSE
7004  IF( nounit )
7005  $ temp = temp*conjg( a( i, i ) )
7006  DO 100, k = 1, i - 1
7007  temp = temp + conjg( a( k, i ) )*b( k, j )
7008  100 CONTINUE
7009  END IF
7010  b( i, j ) = alpha*temp
7011  110 CONTINUE
7012  120 CONTINUE
7013  ELSE
7014  DO 160, j = 1, n
7015  DO 150, i = 1, m
7016  temp = b( i, j )
7017  IF( noconj )THEN
7018  IF( nounit )
7019  $ temp = temp*a( i, i )
7020  DO 130, k = i + 1, m
7021  temp = temp + a( k, i )*b( k, j )
7022  130 CONTINUE
7023  ELSE
7024  IF( nounit )
7025  $ temp = temp*conjg( a( i, i ) )
7026  DO 140, k = i + 1, m
7027  temp = temp + conjg( a( k, i ) )*b( k, j )
7028  140 CONTINUE
7029  END IF
7030  b( i, j ) = alpha*temp
7031  150 CONTINUE
7032  160 CONTINUE
7033  END IF
7034  END IF
7035  ELSE
7036  IF( lsame( transa, 'N' ) )THEN
7037 *
7038 * Form B := alpha*B*A.
7039 *
7040  IF( upper )THEN
7041  DO 200, j = n, 1, -1
7042  temp = alpha
7043  IF( nounit )
7044  $ temp = temp*a( j, j )
7045  DO 170, i = 1, m
7046  b( i, j ) = temp*b( i, j )
7047  170 CONTINUE
7048  DO 190, k = 1, j - 1
7049  IF( a( k, j ).NE.zero )THEN
7050  temp = alpha*a( k, j )
7051  DO 180, i = 1, m
7052  b( i, j ) = b( i, j ) + temp*b( i, k )
7053  180 CONTINUE
7054  END IF
7055  190 CONTINUE
7056  200 CONTINUE
7057  ELSE
7058  DO 240, j = 1, n
7059  temp = alpha
7060  IF( nounit )
7061  $ temp = temp*a( j, j )
7062  DO 210, i = 1, m
7063  b( i, j ) = temp*b( i, j )
7064  210 CONTINUE
7065  DO 230, k = j + 1, n
7066  IF( a( k, j ).NE.zero )THEN
7067  temp = alpha*a( k, j )
7068  DO 220, i = 1, m
7069  b( i, j ) = b( i, j ) + temp*b( i, k )
7070  220 CONTINUE
7071  END IF
7072  230 CONTINUE
7073  240 CONTINUE
7074  END IF
7075  ELSE
7076 *
7077 * Form B := alpha*B*A' or B := alpha*B*conjg( A' ).
7078 *
7079  IF( upper )THEN
7080  DO 280, k = 1, n
7081  DO 260, j = 1, k - 1
7082  IF( a( j, k ).NE.zero )THEN
7083  IF( noconj )THEN
7084  temp = alpha*a( j, k )
7085  ELSE
7086  temp = alpha*conjg( a( j, k ) )
7087  END IF
7088  DO 250, i = 1, m
7089  b( i, j ) = b( i, j ) + temp*b( i, k )
7090  250 CONTINUE
7091  END IF
7092  260 CONTINUE
7093  temp = alpha
7094  IF( nounit )THEN
7095  IF( noconj )THEN
7096  temp = temp*a( k, k )
7097  ELSE
7098  temp = temp*conjg( a( k, k ) )
7099  END IF
7100  END IF
7101  IF( temp.NE.one )THEN
7102  DO 270, i = 1, m
7103  b( i, k ) = temp*b( i, k )
7104  270 CONTINUE
7105  END IF
7106  280 CONTINUE
7107  ELSE
7108  DO 320, k = n, 1, -1
7109  DO 300, j = k + 1, n
7110  IF( a( j, k ).NE.zero )THEN
7111  IF( noconj )THEN
7112  temp = alpha*a( j, k )
7113  ELSE
7114  temp = alpha*conjg( a( j, k ) )
7115  END IF
7116  DO 290, i = 1, m
7117  b( i, j ) = b( i, j ) + temp*b( i, k )
7118  290 CONTINUE
7119  END IF
7120  300 CONTINUE
7121  temp = alpha
7122  IF( nounit )THEN
7123  IF( noconj )THEN
7124  temp = temp*a( k, k )
7125  ELSE
7126  temp = temp*conjg( a( k, k ) )
7127  END IF
7128  END IF
7129  IF( temp.NE.one )THEN
7130  DO 310, i = 1, m
7131  b( i, k ) = temp*b( i, k )
7132  310 CONTINUE
7133  END IF
7134  320 CONTINUE
7135  END IF
7136  END IF
7137  END IF
7138 *
7139  RETURN
7140 *
7141 * End of CTRMM .
7142 *
7143  END
7144  SUBROUTINE ctrmv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
7145 * .. Scalar Arguments ..
7146  INTEGER INCX, LDA, N
7147  CHARACTER*1 DIAG, TRANS, UPLO
7148 * .. Array Arguments ..
7149  COMPLEX A( lda, * ), X( * )
7150 * ..
7151 *
7152 * Purpose
7153 * =======
7154 *
7155 * CTRMV performs one of the matrix-vector operations
7156 *
7157 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
7158 *
7159 * where x is an n element vector and A is an n by n unit, or non-unit,
7160 * upper or lower triangular matrix.
7161 *
7162 * Parameters
7163 * ==========
7164 *
7165 * UPLO - CHARACTER*1.
7166 * On entry, UPLO specifies whether the matrix is an upper or
7167 * lower triangular matrix as follows:
7168 *
7169 * UPLO = 'U' or 'u' A is an upper triangular matrix.
7170 *
7171 * UPLO = 'L' or 'l' A is a lower triangular matrix.
7172 *
7173 * Unchanged on exit.
7174 *
7175 * TRANS - CHARACTER*1.
7176 * On entry, TRANS specifies the operation to be performed as
7177 * follows:
7178 *
7179 * TRANS = 'N' or 'n' x := A*x.
7180 *
7181 * TRANS = 'T' or 't' x := A'*x.
7182 *
7183 * TRANS = 'C' or 'c' x := conjg( A' )*x.
7184 *
7185 * Unchanged on exit.
7186 *
7187 * DIAG - CHARACTER*1.
7188 * On entry, DIAG specifies whether or not A is unit
7189 * triangular as follows:
7190 *
7191 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
7192 *
7193 * DIAG = 'N' or 'n' A is not assumed to be unit
7194 * triangular.
7195 *
7196 * Unchanged on exit.
7197 *
7198 * N - INTEGER.
7199 * On entry, N specifies the order of the matrix A.
7200 * N must be at least zero.
7201 * Unchanged on exit.
7202 *
7203 * A - COMPLEX array of DIMENSION ( LDA, n ).
7204 * Before entry with UPLO = 'U' or 'u', the leading n by n
7205 * upper triangular part of the array A must contain the upper
7206 * triangular matrix and the strictly lower triangular part of
7207 * A is not referenced.
7208 * Before entry with UPLO = 'L' or 'l', the leading n by n
7209 * lower triangular part of the array A must contain the lower
7210 * triangular matrix and the strictly upper triangular part of
7211 * A is not referenced.
7212 * Note that when DIAG = 'U' or 'u', the diagonal elements of
7213 * A are not referenced either, but are assumed to be unity.
7214 * Unchanged on exit.
7215 *
7216 * LDA - INTEGER.
7217 * On entry, LDA specifies the first dimension of A as declared
7218 * in the calling (sub) program. LDA must be at least
7219 * max( 1, n ).
7220 * Unchanged on exit.
7221 *
7222 * X - COMPLEX array of dimension at least
7223 * ( 1 + ( n - 1 )*abs( INCX ) ).
7224 * Before entry, the incremented array X must contain the n
7225 * element vector x. On exit, X is overwritten with the
7226 * tranformed vector x.
7227 *
7228 * INCX - INTEGER.
7229 * On entry, INCX specifies the increment for the elements of
7230 * X. INCX must not be zero.
7231 * Unchanged on exit.
7232 *
7233 *
7234 * Level 2 Blas routine.
7235 *
7236 * -- Written on 22-October-1986.
7237 * Jack Dongarra, Argonne National Lab.
7238 * Jeremy Du Croz, Nag Central Office.
7239 * Sven Hammarling, Nag Central Office.
7240 * Richard Hanson, Sandia National Labs.
7241 *
7242 *
7243 * .. Parameters ..
7244  COMPLEX ZERO
7245  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
7246 * .. Local Scalars ..
7247  COMPLEX TEMP
7248  INTEGER I, INFO, IX, J, JX, KX
7249  LOGICAL NOCONJ, NOUNIT
7250 * .. External Functions ..
7251  LOGICAL LSAME
7252  EXTERNAL lsame
7253 * .. External Subroutines ..
7254  EXTERNAL xerbla
7255 * .. Intrinsic Functions ..
7256  INTRINSIC conjg, max
7257 * ..
7258 * .. Executable Statements ..
7259 *
7260 * Test the input parameters.
7261 *
7262  info = 0
7263  IF ( .NOT.lsame( uplo , 'U' ).AND.
7264  $ .NOT.lsame( uplo , 'L' ) )THEN
7265  info = 1
7266  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
7267  $ .NOT.lsame( trans, 'T' ).AND.
7268  $ .NOT.lsame( trans, 'C' ) )THEN
7269  info = 2
7270  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
7271  $ .NOT.lsame( diag , 'N' ) )THEN
7272  info = 3
7273  ELSE IF( n.LT.0 )THEN
7274  info = 4
7275  ELSE IF( lda.LT.max( 1, n ) )THEN
7276  info = 6
7277  ELSE IF( incx.EQ.0 )THEN
7278  info = 8
7279  END IF
7280  IF( info.NE.0 )THEN
7281  CALL xerbla( 'CTRMV ', info )
7282  RETURN
7283  END IF
7284 *
7285 * Quick return if possible.
7286 *
7287  IF( n.EQ.0 )
7288  $ RETURN
7289 *
7290  noconj = lsame( trans, 'T' )
7291  nounit = lsame( diag , 'N' )
7292 *
7293 * Set up the start point in X if the increment is not unity. This
7294 * will be ( N - 1 )*INCX too small for descending loops.
7295 *
7296  IF( incx.LE.0 )THEN
7297  kx = 1 - ( n - 1 )*incx
7298  ELSE IF( incx.NE.1 )THEN
7299  kx = 1
7300  END IF
7301 *
7302 * Start the operations. In this version the elements of A are
7303 * accessed sequentially with one pass through A.
7304 *
7305  IF( lsame( trans, 'N' ) )THEN
7306 *
7307 * Form x := A*x.
7308 *
7309  IF( lsame( uplo, 'U' ) )THEN
7310  IF( incx.EQ.1 )THEN
7311  DO 20, j = 1, n
7312  IF( x( j ).NE.zero )THEN
7313  temp = x( j )
7314  DO 10, i = 1, j - 1
7315  x( i ) = x( i ) + temp*a( i, j )
7316  10 CONTINUE
7317  IF( nounit )
7318  $ x( j ) = x( j )*a( j, j )
7319  END IF
7320  20 CONTINUE
7321  ELSE
7322  jx = kx
7323  DO 40, j = 1, n
7324  IF( x( jx ).NE.zero )THEN
7325  temp = x( jx )
7326  ix = kx
7327  DO 30, i = 1, j - 1
7328  x( ix ) = x( ix ) + temp*a( i, j )
7329  ix = ix + incx
7330  30 CONTINUE
7331  IF( nounit )
7332  $ x( jx ) = x( jx )*a( j, j )
7333  END IF
7334  jx = jx + incx
7335  40 CONTINUE
7336  END IF
7337  ELSE
7338  IF( incx.EQ.1 )THEN
7339  DO 60, j = n, 1, -1
7340  IF( x( j ).NE.zero )THEN
7341  temp = x( j )
7342  DO 50, i = n, j + 1, -1
7343  x( i ) = x( i ) + temp*a( i, j )
7344  50 CONTINUE
7345  IF( nounit )
7346  $ x( j ) = x( j )*a( j, j )
7347  END IF
7348  60 CONTINUE
7349  ELSE
7350  kx = kx + ( n - 1 )*incx
7351  jx = kx
7352  DO 80, j = n, 1, -1
7353  IF( x( jx ).NE.zero )THEN
7354  temp = x( jx )
7355  ix = kx
7356  DO 70, i = n, j + 1, -1
7357  x( ix ) = x( ix ) + temp*a( i, j )
7358  ix = ix - incx
7359  70 CONTINUE
7360  IF( nounit )
7361  $ x( jx ) = x( jx )*a( j, j )
7362  END IF
7363  jx = jx - incx
7364  80 CONTINUE
7365  END IF
7366  END IF
7367  ELSE
7368 *
7369 * Form x := A'*x or x := conjg( A' )*x.
7370 *
7371  IF( lsame( uplo, 'U' ) )THEN
7372  IF( incx.EQ.1 )THEN
7373  DO 110, j = n, 1, -1
7374  temp = x( j )
7375  IF( noconj )THEN
7376  IF( nounit )
7377  $ temp = temp*a( j, j )
7378  DO 90, i = j - 1, 1, -1
7379  temp = temp + a( i, j )*x( i )
7380  90 CONTINUE
7381  ELSE
7382  IF( nounit )
7383  $ temp = temp*conjg( a( j, j ) )
7384  DO 100, i = j - 1, 1, -1
7385  temp = temp + conjg( a( i, j ) )*x( i )
7386  100 CONTINUE
7387  END IF
7388  x( j ) = temp
7389  110 CONTINUE
7390  ELSE
7391  jx = kx + ( n - 1 )*incx
7392  DO 140, j = n, 1, -1
7393  temp = x( jx )
7394  ix = jx
7395  IF( noconj )THEN
7396  IF( nounit )
7397  $ temp = temp*a( j, j )
7398  DO 120, i = j - 1, 1, -1
7399  ix = ix - incx
7400  temp = temp + a( i, j )*x( ix )
7401  120 CONTINUE
7402  ELSE
7403  IF( nounit )
7404  $ temp = temp*conjg( a( j, j ) )
7405  DO 130, i = j - 1, 1, -1
7406  ix = ix - incx
7407  temp = temp + conjg( a( i, j ) )*x( ix )
7408  130 CONTINUE
7409  END IF
7410  x( jx ) = temp
7411  jx = jx - incx
7412  140 CONTINUE
7413  END IF
7414  ELSE
7415  IF( incx.EQ.1 )THEN
7416  DO 170, j = 1, n
7417  temp = x( j )
7418  IF( noconj )THEN
7419  IF( nounit )
7420  $ temp = temp*a( j, j )
7421  DO 150, i = j + 1, n
7422  temp = temp + a( i, j )*x( i )
7423  150 CONTINUE
7424  ELSE
7425  IF( nounit )
7426  $ temp = temp*conjg( a( j, j ) )
7427  DO 160, i = j + 1, n
7428  temp = temp + conjg( a( i, j ) )*x( i )
7429  160 CONTINUE
7430  END IF
7431  x( j ) = temp
7432  170 CONTINUE
7433  ELSE
7434  jx = kx
7435  DO 200, j = 1, n
7436  temp = x( jx )
7437  ix = jx
7438  IF( noconj )THEN
7439  IF( nounit )
7440  $ temp = temp*a( j, j )
7441  DO 180, i = j + 1, n
7442  ix = ix + incx
7443  temp = temp + a( i, j )*x( ix )
7444  180 CONTINUE
7445  ELSE
7446  IF( nounit )
7447  $ temp = temp*conjg( a( j, j ) )
7448  DO 190, i = j + 1, n
7449  ix = ix + incx
7450  temp = temp + conjg( a( i, j ) )*x( ix )
7451  190 CONTINUE
7452  END IF
7453  x( jx ) = temp
7454  jx = jx + incx
7455  200 CONTINUE
7456  END IF
7457  END IF
7458  END IF
7459 *
7460  RETURN
7461 *
7462 * End of CTRMV .
7463 *
7464  END
7465  SUBROUTINE ctrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
7466  $ b, ldb )
7467 * .. Scalar Arguments ..
7468  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
7469  INTEGER M, N, LDA, LDB
7470  COMPLEX ALPHA
7471 * .. Array Arguments ..
7472  COMPLEX A( lda, * ), B( ldb, * )
7473 * ..
7474 *
7475 * Purpose
7476 * =======
7477 *
7478 * CTRSM solves one of the matrix equations
7479 *
7480 * op( A )*X = alpha*B, or X*op( A ) = alpha*B,
7481 *
7482 * where alpha is a scalar, X and B are m by n matrices, A is a unit, or
7483 * non-unit, upper or lower triangular matrix and op( A ) is one of
7484 *
7485 * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
7486 *
7487 * The matrix X is overwritten on B.
7488 *
7489 * Parameters
7490 * ==========
7491 *
7492 * SIDE - CHARACTER*1.
7493 * On entry, SIDE specifies whether op( A ) appears on the left
7494 * or right of X as follows:
7495 *
7496 * SIDE = 'L' or 'l' op( A )*X = alpha*B.
7497 *
7498 * SIDE = 'R' or 'r' X*op( A ) = alpha*B.
7499 *
7500 * Unchanged on exit.
7501 *
7502 * UPLO - CHARACTER*1.
7503 * On entry, UPLO specifies whether the matrix A is an upper or
7504 * lower triangular matrix as follows:
7505 *
7506 * UPLO = 'U' or 'u' A is an upper triangular matrix.
7507 *
7508 * UPLO = 'L' or 'l' A is a lower triangular matrix.
7509 *
7510 * Unchanged on exit.
7511 *
7512 * TRANSA - CHARACTER*1.
7513 * On entry, TRANSA specifies the form of op( A ) to be used in
7514 * the matrix multiplication as follows:
7515 *
7516 * TRANSA = 'N' or 'n' op( A ) = A.
7517 *
7518 * TRANSA = 'T' or 't' op( A ) = A'.
7519 *
7520 * TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
7521 *
7522 * Unchanged on exit.
7523 *
7524 * DIAG - CHARACTER*1.
7525 * On entry, DIAG specifies whether or not A is unit triangular
7526 * as follows:
7527 *
7528 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
7529 *
7530 * DIAG = 'N' or 'n' A is not assumed to be unit
7531 * triangular.
7532 *
7533 * Unchanged on exit.
7534 *
7535 * M - INTEGER.
7536 * On entry, M specifies the number of rows of B. M must be at
7537 * least zero.
7538 * Unchanged on exit.
7539 *
7540 * N - INTEGER.
7541 * On entry, N specifies the number of columns of B. N must be
7542 * at least zero.
7543 * Unchanged on exit.
7544 *
7545 * ALPHA - COMPLEX .
7546 * On entry, ALPHA specifies the scalar alpha. When alpha is
7547 * zero then A is not referenced and B need not be set before
7548 * entry.
7549 * Unchanged on exit.
7550 *
7551 * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m
7552 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
7553 * Before entry with UPLO = 'U' or 'u', the leading k by k
7554 * upper triangular part of the array A must contain the upper
7555 * triangular matrix and the strictly lower triangular part of
7556 * A is not referenced.
7557 * Before entry with UPLO = 'L' or 'l', the leading k by k
7558 * lower triangular part of the array A must contain the lower
7559 * triangular matrix and the strictly upper triangular part of
7560 * A is not referenced.
7561 * Note that when DIAG = 'U' or 'u', the diagonal elements of
7562 * A are not referenced either, but are assumed to be unity.
7563 * Unchanged on exit.
7564 *
7565 * LDA - INTEGER.
7566 * On entry, LDA specifies the first dimension of A as declared
7567 * in the calling (sub) program. When SIDE = 'L' or 'l' then
7568 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
7569 * then LDA must be at least max( 1, n ).
7570 * Unchanged on exit.
7571 *
7572 * B - COMPLEX array of DIMENSION ( LDB, n ).
7573 * Before entry, the leading m by n part of the array B must
7574 * contain the right-hand side matrix B, and on exit is
7575 * overwritten by the solution matrix X.
7576 *
7577 * LDB - INTEGER.
7578 * On entry, LDB specifies the first dimension of B as declared
7579 * in the calling (sub) program. LDB must be at least
7580 * max( 1, m ).
7581 * Unchanged on exit.
7582 *
7583 *
7584 * Level 3 Blas routine.
7585 *
7586 * -- Written on 8-February-1989.
7587 * Jack Dongarra, Argonne National Laboratory.
7588 * Iain Duff, AERE Harwell.
7589 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
7590 * Sven Hammarling, Numerical Algorithms Group Ltd.
7591 *
7592 *
7593 * .. External Functions ..
7594  LOGICAL LSAME
7595  EXTERNAL lsame
7596 * .. External Subroutines ..
7597  EXTERNAL xerbla
7598 * .. Intrinsic Functions ..
7599  INTRINSIC conjg, max
7600 * .. Local Scalars ..
7601  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
7602  INTEGER I, INFO, J, K, NROWA
7603  COMPLEX TEMP
7604 * .. Parameters ..
7605  COMPLEX ONE
7606  parameter( one = ( 1.0e+0, 0.0e+0 ) )
7607  COMPLEX ZERO
7608  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
7609 * ..
7610 * .. Executable Statements ..
7611 *
7612 * Test the input parameters.
7613 *
7614  lside = lsame( side , 'L' )
7615  IF( lside )THEN
7616  nrowa = m
7617  ELSE
7618  nrowa = n
7619  END IF
7620  noconj = lsame( transa, 'T' )
7621  nounit = lsame( diag , 'N' )
7622  upper = lsame( uplo , 'U' )
7623 *
7624  info = 0
7625  IF( ( .NOT.lside ).AND.
7626  $ ( .NOT.lsame( side , 'R' ) ) )THEN
7627  info = 1
7628  ELSE IF( ( .NOT.upper ).AND.
7629  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
7630  info = 2
7631  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
7632  $ ( .NOT.lsame( transa, 'T' ) ).AND.
7633  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
7634  info = 3
7635  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
7636  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
7637  info = 4
7638  ELSE IF( m .LT.0 )THEN
7639  info = 5
7640  ELSE IF( n .LT.0 )THEN
7641  info = 6
7642  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
7643  info = 9
7644  ELSE IF( ldb.LT.max( 1, m ) )THEN
7645  info = 11
7646  END IF
7647  IF( info.NE.0 )THEN
7648  CALL xerbla( 'CTRSM ', info )
7649  RETURN
7650  END IF
7651 *
7652 * Quick return if possible.
7653 *
7654  IF( n.EQ.0 )
7655  $ RETURN
7656 *
7657 * And when alpha.eq.zero.
7658 *
7659  IF( alpha.EQ.zero )THEN
7660  DO 20, j = 1, n
7661  DO 10, i = 1, m
7662  b( i, j ) = zero
7663  10 CONTINUE
7664  20 CONTINUE
7665  RETURN
7666  END IF
7667 *
7668 * Start the operations.
7669 *
7670  IF( lside )THEN
7671  IF( lsame( transa, 'N' ) )THEN
7672 *
7673 * Form B := alpha*inv( A )*B.
7674 *
7675  IF( upper )THEN
7676  DO 60, j = 1, n
7677  IF( alpha.NE.one )THEN
7678  DO 30, i = 1, m
7679  b( i, j ) = alpha*b( i, j )
7680  30 CONTINUE
7681  END IF
7682  DO 50, k = m, 1, -1
7683  IF( b( k, j ).NE.zero )THEN
7684  IF( nounit )
7685  $ b( k, j ) = b( k, j )/a( k, k )
7686  DO 40, i = 1, k - 1
7687  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
7688  40 CONTINUE
7689  END IF
7690  50 CONTINUE
7691  60 CONTINUE
7692  ELSE
7693  DO 100, j = 1, n
7694  IF( alpha.NE.one )THEN
7695  DO 70, i = 1, m
7696  b( i, j ) = alpha*b( i, j )
7697  70 CONTINUE
7698  END IF
7699  DO 90 k = 1, m
7700  IF( b( k, j ).NE.zero )THEN
7701  IF( nounit )
7702  $ b( k, j ) = b( k, j )/a( k, k )
7703  DO 80, i = k + 1, m
7704  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
7705  80 CONTINUE
7706  END IF
7707  90 CONTINUE
7708  100 CONTINUE
7709  END IF
7710  ELSE
7711 *
7712 * Form B := alpha*inv( A' )*B
7713 * or B := alpha*inv( conjg( A' ) )*B.
7714 *
7715  IF( upper )THEN
7716  DO 140, j = 1, n
7717  DO 130, i = 1, m
7718  temp = alpha*b( i, j )
7719  IF( noconj )THEN
7720  DO 110, k = 1, i - 1
7721  temp = temp - a( k, i )*b( k, j )
7722  110 CONTINUE
7723  IF( nounit )
7724  $ temp = temp/a( i, i )
7725  ELSE
7726  DO 120, k = 1, i - 1
7727  temp = temp - conjg( a( k, i ) )*b( k, j )
7728  120 CONTINUE
7729  IF( nounit )
7730  $ temp = temp/conjg( a( i, i ) )
7731  END IF
7732  b( i, j ) = temp
7733  130 CONTINUE
7734  140 CONTINUE
7735  ELSE
7736  DO 180, j = 1, n
7737  DO 170, i = m, 1, -1
7738  temp = alpha*b( i, j )
7739  IF( noconj )THEN
7740  DO 150, k = i + 1, m
7741  temp = temp - a( k, i )*b( k, j )
7742  150 CONTINUE
7743  IF( nounit )
7744  $ temp = temp/a( i, i )
7745  ELSE
7746  DO 160, k = i + 1, m
7747  temp = temp - conjg( a( k, i ) )*b( k, j )
7748  160 CONTINUE
7749  IF( nounit )
7750  $ temp = temp/conjg( a( i, i ) )
7751  END IF
7752  b( i, j ) = temp
7753  170 CONTINUE
7754  180 CONTINUE
7755  END IF
7756  END IF
7757  ELSE
7758  IF( lsame( transa, 'N' ) )THEN
7759 *
7760 * Form B := alpha*B*inv( A ).
7761 *
7762  IF( upper )THEN
7763  DO 230, j = 1, n
7764  IF( alpha.NE.one )THEN
7765  DO 190, i = 1, m
7766  b( i, j ) = alpha*b( i, j )
7767  190 CONTINUE
7768  END IF
7769  DO 210, k = 1, j - 1
7770  IF( a( k, j ).NE.zero )THEN
7771  DO 200, i = 1, m
7772  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
7773  200 CONTINUE
7774  END IF
7775  210 CONTINUE
7776  IF( nounit )THEN
7777  temp = one/a( j, j )
7778  DO 220, i = 1, m
7779  b( i, j ) = temp*b( i, j )
7780  220 CONTINUE
7781  END IF
7782  230 CONTINUE
7783  ELSE
7784  DO 280, j = n, 1, -1
7785  IF( alpha.NE.one )THEN
7786  DO 240, i = 1, m
7787  b( i, j ) = alpha*b( i, j )
7788  240 CONTINUE
7789  END IF
7790  DO 260, k = j + 1, n
7791  IF( a( k, j ).NE.zero )THEN
7792  DO 250, i = 1, m
7793  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
7794  250 CONTINUE
7795  END IF
7796  260 CONTINUE
7797  IF( nounit )THEN
7798  temp = one/a( j, j )
7799  DO 270, i = 1, m
7800  b( i, j ) = temp*b( i, j )
7801  270 CONTINUE
7802  END IF
7803  280 CONTINUE
7804  END IF
7805  ELSE
7806 *
7807 * Form B := alpha*B*inv( A' )
7808 * or B := alpha*B*inv( conjg( A' ) ).
7809 *
7810  IF( upper )THEN
7811  DO 330, k = n, 1, -1
7812  IF( nounit )THEN
7813  IF( noconj )THEN
7814  temp = one/a( k, k )
7815  ELSE
7816  temp = one/conjg( a( k, k ) )
7817  END IF
7818  DO 290, i = 1, m
7819  b( i, k ) = temp*b( i, k )
7820  290 CONTINUE
7821  END IF
7822  DO 310, j = 1, k - 1
7823  IF( a( j, k ).NE.zero )THEN
7824  IF( noconj )THEN
7825  temp = a( j, k )
7826  ELSE
7827  temp = conjg( a( j, k ) )
7828  END IF
7829  DO 300, i = 1, m
7830  b( i, j ) = b( i, j ) - temp*b( i, k )
7831  300 CONTINUE
7832  END IF
7833  310 CONTINUE
7834  IF( alpha.NE.one )THEN
7835  DO 320, i = 1, m
7836  b( i, k ) = alpha*b( i, k )
7837  320 CONTINUE
7838  END IF
7839  330 CONTINUE
7840  ELSE
7841  DO 380, k = 1, n
7842  IF( nounit )THEN
7843  IF( noconj )THEN
7844  temp = one/a( k, k )
7845  ELSE
7846  temp = one/conjg( a( k, k ) )
7847  END IF
7848  DO 340, i = 1, m
7849  b( i, k ) = temp*b( i, k )
7850  340 CONTINUE
7851  END IF
7852  DO 360, j = k + 1, n
7853  IF( a( j, k ).NE.zero )THEN
7854  IF( noconj )THEN
7855  temp = a( j, k )
7856  ELSE
7857  temp = conjg( a( j, k ) )
7858  END IF
7859  DO 350, i = 1, m
7860  b( i, j ) = b( i, j ) - temp*b( i, k )
7861  350 CONTINUE
7862  END IF
7863  360 CONTINUE
7864  IF( alpha.NE.one )THEN
7865  DO 370, i = 1, m
7866  b( i, k ) = alpha*b( i, k )
7867  370 CONTINUE
7868  END IF
7869  380 CONTINUE
7870  END IF
7871  END IF
7872  END IF
7873 *
7874  RETURN
7875 *
7876 * End of CTRSM .
7877 *
7878  END
7879  SUBROUTINE ctrsv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
7880 * .. Scalar Arguments ..
7881  INTEGER INCX, LDA, N
7882  CHARACTER*1 DIAG, TRANS, UPLO
7883 * .. Array Arguments ..
7884  COMPLEX A( lda, * ), X( * )
7885 * ..
7886 *
7887 * Purpose
7888 * =======
7889 *
7890 * CTRSV solves one of the systems of equations
7891 *
7892 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
7893 *
7894 * where b and x are n element vectors and A is an n by n unit, or
7895 * non-unit, upper or lower triangular matrix.
7896 *
7897 * No test for singularity or near-singularity is included in this
7898 * routine. Such tests must be performed before calling this routine.
7899 *
7900 * Parameters
7901 * ==========
7902 *
7903 * UPLO - CHARACTER*1.
7904 * On entry, UPLO specifies whether the matrix is an upper or
7905 * lower triangular matrix as follows:
7906 *
7907 * UPLO = 'U' or 'u' A is an upper triangular matrix.
7908 *
7909 * UPLO = 'L' or 'l' A is a lower triangular matrix.
7910 *
7911 * Unchanged on exit.
7912 *
7913 * TRANS - CHARACTER*1.
7914 * On entry, TRANS specifies the equations to be solved as
7915 * follows:
7916 *
7917 * TRANS = 'N' or 'n' A*x = b.
7918 *
7919 * TRANS = 'T' or 't' A'*x = b.
7920 *
7921 * TRANS = 'C' or 'c' conjg( A' )*x = b.
7922 *
7923 * Unchanged on exit.
7924 *
7925 * DIAG - CHARACTER*1.
7926 * On entry, DIAG specifies whether or not A is unit
7927 * triangular as follows:
7928 *
7929 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
7930 *
7931 * DIAG = 'N' or 'n' A is not assumed to be unit
7932 * triangular.
7933 *
7934 * Unchanged on exit.
7935 *
7936 * N - INTEGER.
7937 * On entry, N specifies the order of the matrix A.
7938 * N must be at least zero.
7939 * Unchanged on exit.
7940 *
7941 * A - COMPLEX array of DIMENSION ( LDA, n ).
7942 * Before entry with UPLO = 'U' or 'u', the leading n by n
7943 * upper triangular part of the array A must contain the upper
7944 * triangular matrix and the strictly lower triangular part of
7945 * A is not referenced.
7946 * Before entry with UPLO = 'L' or 'l', the leading n by n
7947 * lower triangular part of the array A must contain the lower
7948 * triangular matrix and the strictly upper triangular part of
7949 * A is not referenced.
7950 * Note that when DIAG = 'U' or 'u', the diagonal elements of
7951 * A are not referenced either, but are assumed to be unity.
7952 * Unchanged on exit.
7953 *
7954 * LDA - INTEGER.
7955 * On entry, LDA specifies the first dimension of A as declared
7956 * in the calling (sub) program. LDA must be at least
7957 * max( 1, n ).
7958 * Unchanged on exit.
7959 *
7960 * X - COMPLEX array of dimension at least
7961 * ( 1 + ( n - 1 )*abs( INCX ) ).
7962 * Before entry, the incremented array X must contain the n
7963 * element right-hand side vector b. On exit, X is overwritten
7964 * with the solution vector x.
7965 *
7966 * INCX - INTEGER.
7967 * On entry, INCX specifies the increment for the elements of
7968 * X. INCX must not be zero.
7969 * Unchanged on exit.
7970 *
7971 *
7972 * Level 2 Blas routine.
7973 *
7974 * -- Written on 22-October-1986.
7975 * Jack Dongarra, Argonne National Lab.
7976 * Jeremy Du Croz, Nag Central Office.
7977 * Sven Hammarling, Nag Central Office.
7978 * Richard Hanson, Sandia National Labs.
7979 *
7980 *
7981 * .. Parameters ..
7982  COMPLEX ZERO
7983  parameter( zero = ( 0.0e+0, 0.0e+0 ) )
7984 * .. Local Scalars ..
7985  COMPLEX TEMP
7986  INTEGER I, INFO, IX, J, JX, KX
7987  LOGICAL NOCONJ, NOUNIT
7988 * .. External Functions ..
7989  LOGICAL LSAME
7990  EXTERNAL lsame
7991 * .. External Subroutines ..
7992  EXTERNAL xerbla
7993 * .. Intrinsic Functions ..
7994  INTRINSIC conjg, max
7995 * ..
7996 * .. Executable Statements ..
7997 *
7998 * Test the input parameters.
7999 *
8000  info = 0
8001  IF ( .NOT.lsame( uplo , 'U' ).AND.
8002  $ .NOT.lsame( uplo , 'L' ) )THEN
8003  info = 1
8004  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
8005  $ .NOT.lsame( trans, 'T' ).AND.
8006  $ .NOT.lsame( trans, 'C' ) )THEN
8007  info = 2
8008  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
8009  $ .NOT.lsame( diag , 'N' ) )THEN
8010  info = 3
8011  ELSE IF( n.LT.0 )THEN
8012  info = 4
8013  ELSE IF( lda.LT.max( 1, n ) )THEN
8014  info = 6
8015  ELSE IF( incx.EQ.0 )THEN
8016  info = 8
8017  END IF
8018  IF( info.NE.0 )THEN
8019  CALL xerbla( 'CTRSV ', info )
8020  RETURN
8021  END IF
8022 *
8023 * Quick return if possible.
8024 *
8025  IF( n.EQ.0 )
8026  $ RETURN
8027 *
8028  noconj = lsame( trans, 'T' )
8029  nounit = lsame( diag , 'N' )
8030 *
8031 * Set up the start point in X if the increment is not unity. This
8032 * will be ( N - 1 )*INCX too small for descending loops.
8033 *
8034  IF( incx.LE.0 )THEN
8035  kx = 1 - ( n - 1 )*incx
8036  ELSE IF( incx.NE.1 )THEN
8037  kx = 1
8038  END IF
8039 *
8040 * Start the operations. In this version the elements of A are
8041 * accessed sequentially with one pass through A.
8042 *
8043  IF( lsame( trans, 'N' ) )THEN
8044 *
8045 * Form x := inv( A )*x.
8046 *
8047  IF( lsame( uplo, 'U' ) )THEN
8048  IF( incx.EQ.1 )THEN
8049  DO 20, j = n, 1, -1
8050  IF( x( j ).NE.zero )THEN
8051  IF( nounit )
8052  $ x( j ) = x( j )/a( j, j )
8053  temp = x( j )
8054  DO 10, i = j - 1, 1, -1
8055  x( i ) = x( i ) - temp*a( i, j )
8056  10 CONTINUE
8057  END IF
8058  20 CONTINUE
8059  ELSE
8060  jx = kx + ( n - 1 )*incx
8061  DO 40, j = n, 1, -1
8062  IF( x( jx ).NE.zero )THEN
8063  IF( nounit )
8064  $ x( jx ) = x( jx )/a( j, j )
8065  temp = x( jx )
8066  ix = jx
8067  DO 30, i = j - 1, 1, -1
8068  ix = ix - incx
8069  x( ix ) = x( ix ) - temp*a( i, j )
8070  30 CONTINUE
8071  END IF
8072  jx = jx - incx
8073  40 CONTINUE
8074  END IF
8075  ELSE
8076  IF( incx.EQ.1 )THEN
8077  DO 60, j = 1, n
8078  IF( x( j ).NE.zero )THEN
8079  IF( nounit )
8080  $ x( j ) = x( j )/a( j, j )
8081  temp = x( j )
8082  DO 50, i = j + 1, n
8083  x( i ) = x( i ) - temp*a( i, j )
8084  50 CONTINUE
8085  END IF
8086  60 CONTINUE
8087  ELSE
8088  jx = kx
8089  DO 80, j = 1, n
8090  IF( x( jx ).NE.zero )THEN
8091  IF( nounit )
8092  $ x( jx ) = x( jx )/a( j, j )
8093  temp = x( jx )
8094  ix = jx
8095  DO 70, i = j + 1, n
8096  ix = ix + incx
8097  x( ix ) = x( ix ) - temp*a( i, j )
8098  70 CONTINUE
8099  END IF
8100  jx = jx + incx
8101  80 CONTINUE
8102  END IF
8103  END IF
8104  ELSE
8105 *
8106 * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x.
8107 *
8108  IF( lsame( uplo, 'U' ) )THEN
8109  IF( incx.EQ.1 )THEN
8110  DO 110, j = 1, n
8111  temp = x( j )
8112  IF( noconj )THEN
8113  DO 90, i = 1, j - 1
8114  temp = temp - a( i, j )*x( i )
8115  90 CONTINUE
8116  IF( nounit )
8117  $ temp = temp/a( j, j )
8118  ELSE
8119  DO 100, i = 1, j - 1
8120  temp = temp - conjg( a( i, j ) )*x( i )
8121  100 CONTINUE
8122  IF( nounit )
8123  $ temp = temp/conjg( a( j, j ) )
8124  END IF
8125  x( j ) = temp
8126  110 CONTINUE
8127  ELSE
8128  jx = kx
8129  DO 140, j = 1, n
8130  ix = kx
8131  temp = x( jx )
8132  IF( noconj )THEN
8133  DO 120, i = 1, j - 1
8134  temp = temp - a( i, j )*x( ix )
8135  ix = ix + incx
8136  120 CONTINUE
8137  IF( nounit )
8138  $ temp = temp/a( j, j )
8139  ELSE
8140  DO 130, i = 1, j - 1
8141  temp = temp - conjg( a( i, j ) )*x( ix )
8142  ix = ix + incx
8143  130 CONTINUE
8144  IF( nounit )
8145  $ temp = temp/conjg( a( j, j ) )
8146  END IF
8147  x( jx ) = temp
8148  jx = jx + incx
8149  140 CONTINUE
8150  END IF
8151  ELSE
8152  IF( incx.EQ.1 )THEN
8153  DO 170, j = n, 1, -1
8154  temp = x( j )
8155  IF( noconj )THEN
8156  DO 150, i = n, j + 1, -1
8157  temp = temp - a( i, j )*x( i )
8158  150 CONTINUE
8159  IF( nounit )
8160  $ temp = temp/a( j, j )
8161  ELSE
8162  DO 160, i = n, j + 1, -1
8163  temp = temp - conjg( a( i, j ) )*x( i )
8164  160 CONTINUE
8165  IF( nounit )
8166  $ temp = temp/conjg( a( j, j ) )
8167  END IF
8168  x( j ) = temp
8169  170 CONTINUE
8170  ELSE
8171  kx = kx + ( n - 1 )*incx
8172  jx = kx
8173  DO 200, j = n, 1, -1
8174  ix = kx
8175  temp = x( jx )
8176  IF( noconj )THEN
8177  DO 180, i = n, j + 1, -1
8178  temp = temp - a( i, j )*x( ix )
8179  ix = ix - incx
8180  180 CONTINUE
8181  IF( nounit )
8182  $ temp = temp/a( j, j )
8183  ELSE
8184  DO 190, i = n, j + 1, -1
8185  temp = temp - conjg( a( i, j ) )*x( ix )
8186  ix = ix - incx
8187  190 CONTINUE
8188  IF( nounit )
8189  $ temp = temp/conjg( a( j, j ) )
8190  END IF
8191  x( jx ) = temp
8192  jx = jx - incx
8193  200 CONTINUE
8194  END IF
8195  END IF
8196  END IF
8197 *
8198  RETURN
8199 *
8200 * End of CTRSV .
8201 *
8202  END
8203  double precision function dasum(n,dx,incx)
8204 c
8205 c takes the sum of the absolute values.
8206 c jack dongarra, linpack, 3/11/78.
8207 c modified 3/93 to return if incx .le. 0.
8208 c modified 12/3/93, array(1) declarations changed to array(*)
8209 c
8210  double precision dx(*),dtemp
8211  integer i,incx,m,mp1,n,nincx
8212 c
8213  dasum = 0.0d0
8214  dtemp = 0.0d0
8215  if( n.le.0 .or. incx.le.0 )return
8216  if(incx.eq.1)go to 20
8217 c
8218 c code for increment not equal to 1
8219 c
8220  nincx = n*incx
8221  do 10 i = 1,nincx,incx
8222  dtemp = dtemp + dabs(dx(i))
8223  10 continue
8224  dasum = dtemp
8225  return
8226 c
8227 c code for increment equal to 1
8228 c
8229 c
8230 c clean-up loop
8231 c
8232  20 m = mod(n,6)
8233  if( m .eq. 0 ) go to 40
8234  do 30 i = 1,m
8235  dtemp = dtemp + dabs(dx(i))
8236  30 continue
8237  if( n .lt. 6 ) go to 60
8238  40 mp1 = m + 1
8239  do 50 i = mp1,n,6
8240  dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2))
8241  * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
8242  50 continue
8243  60 dasum = dtemp
8244  return
8245  end
8246  subroutine daxpy(n,da,dx,incx,dy,incy)
8247 c
8248 c constant times a vector plus a vector.
8249 c uses unrolled loops for increments equal to one.
8250 c jack dongarra, linpack, 3/11/78.
8251 c modified 12/3/93, array(1) declarations changed to array(*)
8252 c
8253  double precision dx(*),dy(*),da
8254  integer i,incx,incy,ix,iy,m,mp1,n
8255 c
8256  if(n.le.0)return
8257  if (da .eq. 0.0d0) return
8258  if(incx.eq.1.and.incy.eq.1)go to 20
8259 c
8260 c code for unequal increments or equal increments
8261 c not equal to 1
8262 c
8263  ix = 1
8264  iy = 1
8265  if(incx.lt.0)ix = (-n+1)*incx + 1
8266  if(incy.lt.0)iy = (-n+1)*incy + 1
8267  do 10 i = 1,n
8268  dy(iy) = dy(iy) + da*dx(ix)
8269  ix = ix + incx
8270  iy = iy + incy
8271  10 continue
8272  return
8273 c
8274 c code for both increments equal to 1
8275 c
8276 c
8277 c clean-up loop
8278 c
8279  20 m = mod(n,4)
8280  if( m .eq. 0 ) go to 40
8281  do 30 i = 1,m
8282  dy(i) = dy(i) + da*dx(i)
8283  30 continue
8284  if( n .lt. 4 ) return
8285  40 mp1 = m + 1
8286  do 50 i = mp1,n,4
8287  dy(i) = dy(i) + da*dx(i)
8288  dy(i + 1) = dy(i + 1) + da*dx(i + 1)
8289  dy(i + 2) = dy(i + 2) + da*dx(i + 2)
8290  dy(i + 3) = dy(i + 3) + da*dx(i + 3)
8291  50 continue
8292  return
8293  end
8294  double precision function dcabs1(z)
8295  double complex z,zz
8296  double precision t(2)
8297  equivalence(zz,t(1))
8298  zz = z
8299  dcabs1 = dabs(t(1)) + dabs(t(2))
8300  return
8301  end
8302  subroutine dcopy(n,dx,incx,dy,incy)
8303 c
8304 c copies a vector, x, to a vector, y.
8305 c uses unrolled loops for increments equal to one.
8306 c jack dongarra, linpack, 3/11/78.
8307 c modified 12/3/93, array(1) declarations changed to array(*)
8308 c
8309  double precision dx(*),dy(*)
8310  integer i,incx,incy,ix,iy,m,mp1,n
8311 c
8312  if(n.le.0)return
8313  if(incx.eq.1.and.incy.eq.1)go to 20
8314 c
8315 c code for unequal increments or equal increments
8316 c not equal to 1
8317 c
8318  ix = 1
8319  iy = 1
8320  if(incx.lt.0)ix = (-n+1)*incx + 1
8321  if(incy.lt.0)iy = (-n+1)*incy + 1
8322  do 10 i = 1,n
8323  dy(iy) = dx(ix)
8324  ix = ix + incx
8325  iy = iy + incy
8326  10 continue
8327  return
8328 c
8329 c code for both increments equal to 1
8330 c
8331 c
8332 c clean-up loop
8333 c
8334  20 m = mod(n,7)
8335  if( m .eq. 0 ) go to 40
8336  do 30 i = 1,m
8337  dy(i) = dx(i)
8338  30 continue
8339  if( n .lt. 7 ) return
8340  40 mp1 = m + 1
8341  do 50 i = mp1,n,7
8342  dy(i) = dx(i)
8343  dy(i + 1) = dx(i + 1)
8344  dy(i + 2) = dx(i + 2)
8345  dy(i + 3) = dx(i + 3)
8346  dy(i + 4) = dx(i + 4)
8347  dy(i + 5) = dx(i + 5)
8348  dy(i + 6) = dx(i + 6)
8349  50 continue
8350  return
8351  end
8352  double precision function ddot(n,dx,incx,dy,incy)
8353 c
8354 c forms the dot product of two vectors.
8355 c uses unrolled loops for increments equal to one.
8356 c jack dongarra, linpack, 3/11/78.
8357 c modified 12/3/93, array(1) declarations changed to array(*)
8358 c
8359  double precision dx(*),dy(*),dtemp
8360  integer i,incx,incy,ix,iy,m,mp1,n
8361 c
8362  ddot = 0.0d0
8363  dtemp = 0.0d0
8364  if(n.le.0)return
8365  if(incx.eq.1.and.incy.eq.1)go to 20
8366 c
8367 c code for unequal increments or equal increments
8368 c not equal to 1
8369 c
8370  ix = 1
8371  iy = 1
8372  if(incx.lt.0)ix = (-n+1)*incx + 1
8373  if(incy.lt.0)iy = (-n+1)*incy + 1
8374  do 10 i = 1,n
8375  dtemp = dtemp + dx(ix)*dy(iy)
8376  ix = ix + incx
8377  iy = iy + incy
8378  10 continue
8379  ddot = dtemp
8380  return
8381 c
8382 c code for both increments equal to 1
8383 c
8384 c
8385 c clean-up loop
8386 c
8387  20 m = mod(n,5)
8388  if( m .eq. 0 ) go to 40
8389  do 30 i = 1,m
8390  dtemp = dtemp + dx(i)*dy(i)
8391  30 continue
8392  if( n .lt. 5 ) go to 60
8393  40 mp1 = m + 1
8394  do 50 i = mp1,n,5
8395  dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
8396  * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
8397  50 continue
8398  60 ddot = dtemp
8399  return
8400  end
8401  SUBROUTINE dgbmv ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
8402  $ beta, y, incy )
8403 * .. Scalar Arguments ..
8404  DOUBLE PRECISION ALPHA, BETA
8405  INTEGER INCX, INCY, KL, KU, LDA, M, N
8406  CHARACTER*1 TRANS
8407 * .. Array Arguments ..
8408  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
8409 * ..
8410 *
8411 * Purpose
8412 * =======
8413 *
8414 * DGBMV performs one of the matrix-vector operations
8415 *
8416 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
8417 *
8418 * where alpha and beta are scalars, x and y are vectors and A is an
8419 * m by n band matrix, with kl sub-diagonals and ku super-diagonals.
8420 *
8421 * Parameters
8422 * ==========
8423 *
8424 * TRANS - CHARACTER*1.
8425 * On entry, TRANS specifies the operation to be performed as
8426 * follows:
8427 *
8428 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
8429 *
8430 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
8431 *
8432 * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
8433 *
8434 * Unchanged on exit.
8435 *
8436 * M - INTEGER.
8437 * On entry, M specifies the number of rows of the matrix A.
8438 * M must be at least zero.
8439 * Unchanged on exit.
8440 *
8441 * N - INTEGER.
8442 * On entry, N specifies the number of columns of the matrix A.
8443 * N must be at least zero.
8444 * Unchanged on exit.
8445 *
8446 * KL - INTEGER.
8447 * On entry, KL specifies the number of sub-diagonals of the
8448 * matrix A. KL must satisfy 0 .le. KL.
8449 * Unchanged on exit.
8450 *
8451 * KU - INTEGER.
8452 * On entry, KU specifies the number of super-diagonals of the
8453 * matrix A. KU must satisfy 0 .le. KU.
8454 * Unchanged on exit.
8455 *
8456 * ALPHA - DOUBLE PRECISION.
8457 * On entry, ALPHA specifies the scalar alpha.
8458 * Unchanged on exit.
8459 *
8460 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
8461 * Before entry, the leading ( kl + ku + 1 ) by n part of the
8462 * array A must contain the matrix of coefficients, supplied
8463 * column by column, with the leading diagonal of the matrix in
8464 * row ( ku + 1 ) of the array, the first super-diagonal
8465 * starting at position 2 in row ku, the first sub-diagonal
8466 * starting at position 1 in row ( ku + 2 ), and so on.
8467 * Elements in the array A that do not correspond to elements
8468 * in the band matrix (such as the top left ku by ku triangle)
8469 * are not referenced.
8470 * The following program segment will transfer a band matrix
8471 * from conventional full matrix storage to band storage:
8472 *
8473 * DO 20, J = 1, N
8474 * K = KU + 1 - J
8475 * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
8476 * A( K + I, J ) = matrix( I, J )
8477 * 10 CONTINUE
8478 * 20 CONTINUE
8479 *
8480 * Unchanged on exit.
8481 *
8482 * LDA - INTEGER.
8483 * On entry, LDA specifies the first dimension of A as declared
8484 * in the calling (sub) program. LDA must be at least
8485 * ( kl + ku + 1 ).
8486 * Unchanged on exit.
8487 *
8488 * X - DOUBLE PRECISION array of DIMENSION at least
8489 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
8490 * and at least
8491 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
8492 * Before entry, the incremented array X must contain the
8493 * vector x.
8494 * Unchanged on exit.
8495 *
8496 * INCX - INTEGER.
8497 * On entry, INCX specifies the increment for the elements of
8498 * X. INCX must not be zero.
8499 * Unchanged on exit.
8500 *
8501 * BETA - DOUBLE PRECISION.
8502 * On entry, BETA specifies the scalar beta. When BETA is
8503 * supplied as zero then Y need not be set on input.
8504 * Unchanged on exit.
8505 *
8506 * Y - DOUBLE PRECISION array of DIMENSION at least
8507 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
8508 * and at least
8509 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
8510 * Before entry, the incremented array Y must contain the
8511 * vector y. On exit, Y is overwritten by the updated vector y.
8512 *
8513 * INCY - INTEGER.
8514 * On entry, INCY specifies the increment for the elements of
8515 * Y. INCY must not be zero.
8516 * Unchanged on exit.
8517 *
8518 *
8519 * Level 2 Blas routine.
8520 *
8521 * -- Written on 22-October-1986.
8522 * Jack Dongarra, Argonne National Lab.
8523 * Jeremy Du Croz, Nag Central Office.
8524 * Sven Hammarling, Nag Central Office.
8525 * Richard Hanson, Sandia National Labs.
8526 *
8527 * .. Parameters ..
8528  DOUBLE PRECISION ONE , ZERO
8529  parameter( one = 1.0d+0, zero = 0.0d+0 )
8530 * .. Local Scalars ..
8531  DOUBLE PRECISION TEMP
8532  INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
8533  $ lenx, leny
8534 * .. External Functions ..
8535  LOGICAL LSAME
8536  EXTERNAL lsame
8537 * .. External Subroutines ..
8538  EXTERNAL xerbla
8539 * .. Intrinsic Functions ..
8540  INTRINSIC max, min
8541 * ..
8542 * .. Executable Statements ..
8543 *
8544 * Test the input parameters.
8545 *
8546  info = 0
8547  IF ( .NOT.lsame( trans, 'N' ).AND.
8548  $ .NOT.lsame( trans, 'T' ).AND.
8549  $ .NOT.lsame( trans, 'C' ) )THEN
8550  info = 1
8551  ELSE IF( m.LT.0 )THEN
8552  info = 2
8553  ELSE IF( n.LT.0 )THEN
8554  info = 3
8555  ELSE IF( kl.LT.0 )THEN
8556  info = 4
8557  ELSE IF( ku.LT.0 )THEN
8558  info = 5
8559  ELSE IF( lda.LT.( kl + ku + 1 ) )THEN
8560  info = 8
8561  ELSE IF( incx.EQ.0 )THEN
8562  info = 10
8563  ELSE IF( incy.EQ.0 )THEN
8564  info = 13
8565  END IF
8566  IF( info.NE.0 )THEN
8567  CALL xerbla( 'DGBMV ', info )
8568  RETURN
8569  END IF
8570 *
8571 * Quick return if possible.
8572 *
8573  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
8574  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
8575  $ RETURN
8576 *
8577 * Set LENX and LENY, the lengths of the vectors x and y, and set
8578 * up the start points in X and Y.
8579 *
8580  IF( lsame( trans, 'N' ) )THEN
8581  lenx = n
8582  leny = m
8583  ELSE
8584  lenx = m
8585  leny = n
8586  END IF
8587  IF( incx.GT.0 )THEN
8588  kx = 1
8589  ELSE
8590  kx = 1 - ( lenx - 1 )*incx
8591  END IF
8592  IF( incy.GT.0 )THEN
8593  ky = 1
8594  ELSE
8595  ky = 1 - ( leny - 1 )*incy
8596  END IF
8597 *
8598 * Start the operations. In this version the elements of A are
8599 * accessed sequentially with one pass through the band part of A.
8600 *
8601 * First form y := beta*y.
8602 *
8603  IF( beta.NE.one )THEN
8604  IF( incy.EQ.1 )THEN
8605  IF( beta.EQ.zero )THEN
8606  DO 10, i = 1, leny
8607  y( i ) = zero
8608  10 CONTINUE
8609  ELSE
8610  DO 20, i = 1, leny
8611  y( i ) = beta*y( i )
8612  20 CONTINUE
8613  END IF
8614  ELSE
8615  iy = ky
8616  IF( beta.EQ.zero )THEN
8617  DO 30, i = 1, leny
8618  y( iy ) = zero
8619  iy = iy + incy
8620  30 CONTINUE
8621  ELSE
8622  DO 40, i = 1, leny
8623  y( iy ) = beta*y( iy )
8624  iy = iy + incy
8625  40 CONTINUE
8626  END IF
8627  END IF
8628  END IF
8629  IF( alpha.EQ.zero )
8630  $ RETURN
8631  kup1 = ku + 1
8632  IF( lsame( trans, 'N' ) )THEN
8633 *
8634 * Form y := alpha*A*x + y.
8635 *
8636  jx = kx
8637  IF( incy.EQ.1 )THEN
8638  DO 60, j = 1, n
8639  IF( x( jx ).NE.zero )THEN
8640  temp = alpha*x( jx )
8641  k = kup1 - j
8642  DO 50, i = max( 1, j - ku ), min( m, j + kl )
8643  y( i ) = y( i ) + temp*a( k + i, j )
8644  50 CONTINUE
8645  END IF
8646  jx = jx + incx
8647  60 CONTINUE
8648  ELSE
8649  DO 80, j = 1, n
8650  IF( x( jx ).NE.zero )THEN
8651  temp = alpha*x( jx )
8652  iy = ky
8653  k = kup1 - j
8654  DO 70, i = max( 1, j - ku ), min( m, j + kl )
8655  y( iy ) = y( iy ) + temp*a( k + i, j )
8656  iy = iy + incy
8657  70 CONTINUE
8658  END IF
8659  jx = jx + incx
8660  IF( j.GT.ku )
8661  $ ky = ky + incy
8662  80 CONTINUE
8663  END IF
8664  ELSE
8665 *
8666 * Form y := alpha*A'*x + y.
8667 *
8668  jy = ky
8669  IF( incx.EQ.1 )THEN
8670  DO 100, j = 1, n
8671  temp = zero
8672  k = kup1 - j
8673  DO 90, i = max( 1, j - ku ), min( m, j + kl )
8674  temp = temp + a( k + i, j )*x( i )
8675  90 CONTINUE
8676  y( jy ) = y( jy ) + alpha*temp
8677  jy = jy + incy
8678  100 CONTINUE
8679  ELSE
8680  DO 120, j = 1, n
8681  temp = zero
8682  ix = kx
8683  k = kup1 - j
8684  DO 110, i = max( 1, j - ku ), min( m, j + kl )
8685  temp = temp + a( k + i, j )*x( ix )
8686  ix = ix + incx
8687  110 CONTINUE
8688  y( jy ) = y( jy ) + alpha*temp
8689  jy = jy + incy
8690  IF( j.GT.ku )
8691  $ kx = kx + incx
8692  120 CONTINUE
8693  END IF
8694  END IF
8695 *
8696  RETURN
8697 *
8698 * End of DGBMV .
8699 *
8700  END
8701  SUBROUTINE dgemm ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
8702  $ beta, c, ldc )
8703 * .. Scalar Arguments ..
8704  CHARACTER*1 TRANSA, TRANSB
8705  INTEGER M, N, K, LDA, LDB, LDC
8706  DOUBLE PRECISION ALPHA, BETA
8707 * .. Array Arguments ..
8708  DOUBLE PRECISION A( lda, * ), B( ldb, * ), C( ldc, * )
8709 * ..
8710 *
8711 * Purpose
8712 * =======
8713 *
8714 * DGEMM performs one of the matrix-matrix operations
8715 *
8716 * C := alpha*op( A )*op( B ) + beta*C,
8717 *
8718 * where op( X ) is one of
8719 *
8720 * op( X ) = X or op( X ) = X',
8721 *
8722 * alpha and beta are scalars, and A, B and C are matrices, with op( A )
8723 * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
8724 *
8725 * Parameters
8726 * ==========
8727 *
8728 * TRANSA - CHARACTER*1.
8729 * On entry, TRANSA specifies the form of op( A ) to be used in
8730 * the matrix multiplication as follows:
8731 *
8732 * TRANSA = 'N' or 'n', op( A ) = A.
8733 *
8734 * TRANSA = 'T' or 't', op( A ) = A'.
8735 *
8736 * TRANSA = 'C' or 'c', op( A ) = A'.
8737 *
8738 * Unchanged on exit.
8739 *
8740 * TRANSB - CHARACTER*1.
8741 * On entry, TRANSB specifies the form of op( B ) to be used in
8742 * the matrix multiplication as follows:
8743 *
8744 * TRANSB = 'N' or 'n', op( B ) = B.
8745 *
8746 * TRANSB = 'T' or 't', op( B ) = B'.
8747 *
8748 * TRANSB = 'C' or 'c', op( B ) = B'.
8749 *
8750 * Unchanged on exit.
8751 *
8752 * M - INTEGER.
8753 * On entry, M specifies the number of rows of the matrix
8754 * op( A ) and of the matrix C. M must be at least zero.
8755 * Unchanged on exit.
8756 *
8757 * N - INTEGER.
8758 * On entry, N specifies the number of columns of the matrix
8759 * op( B ) and the number of columns of the matrix C. N must be
8760 * at least zero.
8761 * Unchanged on exit.
8762 *
8763 * K - INTEGER.
8764 * On entry, K specifies the number of columns of the matrix
8765 * op( A ) and the number of rows of the matrix op( B ). K must
8766 * be at least zero.
8767 * Unchanged on exit.
8768 *
8769 * ALPHA - DOUBLE PRECISION.
8770 * On entry, ALPHA specifies the scalar alpha.
8771 * Unchanged on exit.
8772 *
8773 * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
8774 * k when TRANSA = 'N' or 'n', and is m otherwise.
8775 * Before entry with TRANSA = 'N' or 'n', the leading m by k
8776 * part of the array A must contain the matrix A, otherwise
8777 * the leading k by m part of the array A must contain the
8778 * matrix A.
8779 * Unchanged on exit.
8780 *
8781 * LDA - INTEGER.
8782 * On entry, LDA specifies the first dimension of A as declared
8783 * in the calling (sub) program. When TRANSA = 'N' or 'n' then
8784 * LDA must be at least max( 1, m ), otherwise LDA must be at
8785 * least max( 1, k ).
8786 * Unchanged on exit.
8787 *
8788 * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
8789 * n when TRANSB = 'N' or 'n', and is k otherwise.
8790 * Before entry with TRANSB = 'N' or 'n', the leading k by n
8791 * part of the array B must contain the matrix B, otherwise
8792 * the leading n by k part of the array B must contain the
8793 * matrix B.
8794 * Unchanged on exit.
8795 *
8796 * LDB - INTEGER.
8797 * On entry, LDB specifies the first dimension of B as declared
8798 * in the calling (sub) program. When TRANSB = 'N' or 'n' then
8799 * LDB must be at least max( 1, k ), otherwise LDB must be at
8800 * least max( 1, n ).
8801 * Unchanged on exit.
8802 *
8803 * BETA - DOUBLE PRECISION.
8804 * On entry, BETA specifies the scalar beta. When BETA is
8805 * supplied as zero then C need not be set on input.
8806 * Unchanged on exit.
8807 *
8808 * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
8809 * Before entry, the leading m by n part of the array C must
8810 * contain the matrix C, except when beta is zero, in which
8811 * case C need not be set on entry.
8812 * On exit, the array C is overwritten by the m by n matrix
8813 * ( alpha*op( A )*op( B ) + beta*C ).
8814 *
8815 * LDC - INTEGER.
8816 * On entry, LDC specifies the first dimension of C as declared
8817 * in the calling (sub) program. LDC must be at least
8818 * max( 1, m ).
8819 * Unchanged on exit.
8820 *
8821 *
8822 * Level 3 Blas routine.
8823 *
8824 * -- Written on 8-February-1989.
8825 * Jack Dongarra, Argonne National Laboratory.
8826 * Iain Duff, AERE Harwell.
8827 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
8828 * Sven Hammarling, Numerical Algorithms Group Ltd.
8829 *
8830 *
8831 * .. External Functions ..
8832  LOGICAL LSAME
8833  EXTERNAL lsame
8834 * .. External Subroutines ..
8835  EXTERNAL xerbla
8836 * .. Intrinsic Functions ..
8837  INTRINSIC max
8838 * .. Local Scalars ..
8839  LOGICAL NOTA, NOTB
8840  INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
8841  DOUBLE PRECISION TEMP
8842 * .. Parameters ..
8843  DOUBLE PRECISION ONE , ZERO
8844  parameter( one = 1.0d+0, zero = 0.0d+0 )
8845 * ..
8846 * .. Executable Statements ..
8847 *
8848 * Set NOTA and NOTB as true if A and B respectively are not
8849 * transposed and set NROWA, NCOLA and NROWB as the number of rows
8850 * and columns of A and the number of rows of B respectively.
8851 *
8852  nota = lsame( transa, 'N' )
8853  notb = lsame( transb, 'N' )
8854  IF( nota )THEN
8855  nrowa = m
8856  ncola = k
8857  ELSE
8858  nrowa = k
8859  ncola = m
8860  END IF
8861  IF( notb )THEN
8862  nrowb = k
8863  ELSE
8864  nrowb = n
8865  END IF
8866 *
8867 * Test the input parameters.
8868 *
8869  info = 0
8870  IF( ( .NOT.nota ).AND.
8871  $ ( .NOT.lsame( transa, 'C' ) ).AND.
8872  $ ( .NOT.lsame( transa, 'T' ) ) )THEN
8873  info = 1
8874  ELSE IF( ( .NOT.notb ).AND.
8875  $ ( .NOT.lsame( transb, 'C' ) ).AND.
8876  $ ( .NOT.lsame( transb, 'T' ) ) )THEN
8877  info = 2
8878  ELSE IF( m .LT.0 )THEN
8879  info = 3
8880  ELSE IF( n .LT.0 )THEN
8881  info = 4
8882  ELSE IF( k .LT.0 )THEN
8883  info = 5
8884  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
8885  info = 8
8886  ELSE IF( ldb.LT.max( 1, nrowb ) )THEN
8887  info = 10
8888  ELSE IF( ldc.LT.max( 1, m ) )THEN
8889  info = 13
8890  END IF
8891  IF( info.NE.0 )THEN
8892  CALL xerbla( 'DGEMM ', info )
8893  RETURN
8894  END IF
8895 *
8896 * Quick return if possible.
8897 *
8898  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
8899  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
8900  $ RETURN
8901 *
8902 * And if alpha.eq.zero.
8903 *
8904  IF( alpha.EQ.zero )THEN
8905  IF( beta.EQ.zero )THEN
8906  DO 20, j = 1, n
8907  DO 10, i = 1, m
8908  c( i, j ) = zero
8909  10 CONTINUE
8910  20 CONTINUE
8911  ELSE
8912  DO 40, j = 1, n
8913  DO 30, i = 1, m
8914  c( i, j ) = beta*c( i, j )
8915  30 CONTINUE
8916  40 CONTINUE
8917  END IF
8918  RETURN
8919  END IF
8920 *
8921 * Start the operations.
8922 *
8923  IF( notb )THEN
8924  IF( nota )THEN
8925 *
8926 * Form C := alpha*A*B + beta*C.
8927 *
8928  DO 90, j = 1, n
8929  IF( beta.EQ.zero )THEN
8930  DO 50, i = 1, m
8931  c( i, j ) = zero
8932  50 CONTINUE
8933  ELSE IF( beta.NE.one )THEN
8934  DO 60, i = 1, m
8935  c( i, j ) = beta*c( i, j )
8936  60 CONTINUE
8937  END IF
8938  DO 80, l = 1, k
8939  IF( b( l, j ).NE.zero )THEN
8940  temp = alpha*b( l, j )
8941  DO 70, i = 1, m
8942  c( i, j ) = c( i, j ) + temp*a( i, l )
8943  70 CONTINUE
8944  END IF
8945  80 CONTINUE
8946  90 CONTINUE
8947  ELSE
8948 *
8949 * Form C := alpha*A'*B + beta*C
8950 *
8951  DO 120, j = 1, n
8952  DO 110, i = 1, m
8953  temp = zero
8954  DO 100, l = 1, k
8955  temp = temp + a( l, i )*b( l, j )
8956  100 CONTINUE
8957  IF( beta.EQ.zero )THEN
8958  c( i, j ) = alpha*temp
8959  ELSE
8960  c( i, j ) = alpha*temp + beta*c( i, j )
8961  END IF
8962  110 CONTINUE
8963  120 CONTINUE
8964  END IF
8965  ELSE
8966  IF( nota )THEN
8967 *
8968 * Form C := alpha*A*B' + beta*C
8969 *
8970  DO 170, j = 1, n
8971  IF( beta.EQ.zero )THEN
8972  DO 130, i = 1, m
8973  c( i, j ) = zero
8974  130 CONTINUE
8975  ELSE IF( beta.NE.one )THEN
8976  DO 140, i = 1, m
8977  c( i, j ) = beta*c( i, j )
8978  140 CONTINUE
8979  END IF
8980  DO 160, l = 1, k
8981  IF( b( j, l ).NE.zero )THEN
8982  temp = alpha*b( j, l )
8983  DO 150, i = 1, m
8984  c( i, j ) = c( i, j ) + temp*a( i, l )
8985  150 CONTINUE
8986  END IF
8987  160 CONTINUE
8988  170 CONTINUE
8989  ELSE
8990 *
8991 * Form C := alpha*A'*B' + beta*C
8992 *
8993  DO 200, j = 1, n
8994  DO 190, i = 1, m
8995  temp = zero
8996  DO 180, l = 1, k
8997  temp = temp + a( l, i )*b( j, l )
8998  180 CONTINUE
8999  IF( beta.EQ.zero )THEN
9000  c( i, j ) = alpha*temp
9001  ELSE
9002  c( i, j ) = alpha*temp + beta*c( i, j )
9003  END IF
9004  190 CONTINUE
9005  200 CONTINUE
9006  END IF
9007  END IF
9008 *
9009  RETURN
9010 *
9011 * End of DGEMM .
9012 *
9013  END
9014  SUBROUTINE dgemv ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
9015  $ beta, y, incy )
9016 * .. Scalar Arguments ..
9017  DOUBLE PRECISION ALPHA, BETA
9018  INTEGER INCX, INCY, LDA, M, N
9019  CHARACTER*1 TRANS
9020 * .. Array Arguments ..
9021  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
9022 * ..
9023 *
9024 * Purpose
9025 * =======
9026 *
9027 * DGEMV performs one of the matrix-vector operations
9028 *
9029 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
9030 *
9031 * where alpha and beta are scalars, x and y are vectors and A is an
9032 * m by n matrix.
9033 *
9034 * Parameters
9035 * ==========
9036 *
9037 * TRANS - CHARACTER*1.
9038 * On entry, TRANS specifies the operation to be performed as
9039 * follows:
9040 *
9041 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
9042 *
9043 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
9044 *
9045 * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
9046 *
9047 * Unchanged on exit.
9048 *
9049 * M - INTEGER.
9050 * On entry, M specifies the number of rows of the matrix A.
9051 * M must be at least zero.
9052 * Unchanged on exit.
9053 *
9054 * N - INTEGER.
9055 * On entry, N specifies the number of columns of the matrix A.
9056 * N must be at least zero.
9057 * Unchanged on exit.
9058 *
9059 * ALPHA - DOUBLE PRECISION.
9060 * On entry, ALPHA specifies the scalar alpha.
9061 * Unchanged on exit.
9062 *
9063 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
9064 * Before entry, the leading m by n part of the array A must
9065 * contain the matrix of coefficients.
9066 * Unchanged on exit.
9067 *
9068 * LDA - INTEGER.
9069 * On entry, LDA specifies the first dimension of A as declared
9070 * in the calling (sub) program. LDA must be at least
9071 * max( 1, m ).
9072 * Unchanged on exit.
9073 *
9074 * X - DOUBLE PRECISION array of DIMENSION at least
9075 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
9076 * and at least
9077 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
9078 * Before entry, the incremented array X must contain the
9079 * vector x.
9080 * Unchanged on exit.
9081 *
9082 * INCX - INTEGER.
9083 * On entry, INCX specifies the increment for the elements of
9084 * X. INCX must not be zero.
9085 * Unchanged on exit.
9086 *
9087 * BETA - DOUBLE PRECISION.
9088 * On entry, BETA specifies the scalar beta. When BETA is
9089 * supplied as zero then Y need not be set on input.
9090 * Unchanged on exit.
9091 *
9092 * Y - DOUBLE PRECISION array of DIMENSION at least
9093 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
9094 * and at least
9095 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
9096 * Before entry with BETA non-zero, the incremented array Y
9097 * must contain the vector y. On exit, Y is overwritten by the
9098 * updated vector y.
9099 *
9100 * INCY - INTEGER.
9101 * On entry, INCY specifies the increment for the elements of
9102 * Y. INCY must not be zero.
9103 * Unchanged on exit.
9104 *
9105 *
9106 * Level 2 Blas routine.
9107 *
9108 * -- Written on 22-October-1986.
9109 * Jack Dongarra, Argonne National Lab.
9110 * Jeremy Du Croz, Nag Central Office.
9111 * Sven Hammarling, Nag Central Office.
9112 * Richard Hanson, Sandia National Labs.
9113 *
9114 *
9115 * .. Parameters ..
9116  DOUBLE PRECISION ONE , ZERO
9117  parameter( one = 1.0d+0, zero = 0.0d+0 )
9118 * .. Local Scalars ..
9119  DOUBLE PRECISION TEMP
9120  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
9121 * .. External Functions ..
9122  LOGICAL LSAME
9123  EXTERNAL lsame
9124 * .. External Subroutines ..
9125  EXTERNAL xerbla
9126 * .. Intrinsic Functions ..
9127  INTRINSIC max
9128 * ..
9129 * .. Executable Statements ..
9130 *
9131 * Test the input parameters.
9132 *
9133  info = 0
9134  IF ( .NOT.lsame( trans, 'N' ).AND.
9135  $ .NOT.lsame( trans, 'T' ).AND.
9136  $ .NOT.lsame( trans, 'C' ) )THEN
9137  info = 1
9138  ELSE IF( m.LT.0 )THEN
9139  info = 2
9140  ELSE IF( n.LT.0 )THEN
9141  info = 3
9142  ELSE IF( lda.LT.max( 1, m ) )THEN
9143  info = 6
9144  ELSE IF( incx.EQ.0 )THEN
9145  info = 8
9146  ELSE IF( incy.EQ.0 )THEN
9147  info = 11
9148  END IF
9149  IF( info.NE.0 )THEN
9150  CALL xerbla( 'DGEMV ', info )
9151  RETURN
9152  END IF
9153 *
9154 * Quick return if possible.
9155 *
9156  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
9157  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
9158  $ RETURN
9159 *
9160 * Set LENX and LENY, the lengths of the vectors x and y, and set
9161 * up the start points in X and Y.
9162 *
9163  IF( lsame( trans, 'N' ) )THEN
9164  lenx = n
9165  leny = m
9166  ELSE
9167  lenx = m
9168  leny = n
9169  END IF
9170  IF( incx.GT.0 )THEN
9171  kx = 1
9172  ELSE
9173  kx = 1 - ( lenx - 1 )*incx
9174  END IF
9175  IF( incy.GT.0 )THEN
9176  ky = 1
9177  ELSE
9178  ky = 1 - ( leny - 1 )*incy
9179  END IF
9180 *
9181 * Start the operations. In this version the elements of A are
9182 * accessed sequentially with one pass through A.
9183 *
9184 * First form y := beta*y.
9185 *
9186  IF( beta.NE.one )THEN
9187  IF( incy.EQ.1 )THEN
9188  IF( beta.EQ.zero )THEN
9189  DO 10, i = 1, leny
9190  y( i ) = zero
9191  10 CONTINUE
9192  ELSE
9193  DO 20, i = 1, leny
9194  y( i ) = beta*y( i )
9195  20 CONTINUE
9196  END IF
9197  ELSE
9198  iy = ky
9199  IF( beta.EQ.zero )THEN
9200  DO 30, i = 1, leny
9201  y( iy ) = zero
9202  iy = iy + incy
9203  30 CONTINUE
9204  ELSE
9205  DO 40, i = 1, leny
9206  y( iy ) = beta*y( iy )
9207  iy = iy + incy
9208  40 CONTINUE
9209  END IF
9210  END IF
9211  END IF
9212  IF( alpha.EQ.zero )
9213  $ RETURN
9214  IF( lsame( trans, 'N' ) )THEN
9215 *
9216 * Form y := alpha*A*x + y.
9217 *
9218  jx = kx
9219  IF( incy.EQ.1 )THEN
9220  DO 60, j = 1, n
9221  IF( x( jx ).NE.zero )THEN
9222  temp = alpha*x( jx )
9223  DO 50, i = 1, m
9224  y( i ) = y( i ) + temp*a( i, j )
9225  50 CONTINUE
9226  END IF
9227  jx = jx + incx
9228  60 CONTINUE
9229  ELSE
9230  DO 80, j = 1, n
9231  IF( x( jx ).NE.zero )THEN
9232  temp = alpha*x( jx )
9233  iy = ky
9234  DO 70, i = 1, m
9235  y( iy ) = y( iy ) + temp*a( i, j )
9236  iy = iy + incy
9237  70 CONTINUE
9238  END IF
9239  jx = jx + incx
9240  80 CONTINUE
9241  END IF
9242  ELSE
9243 *
9244 * Form y := alpha*A'*x + y.
9245 *
9246  jy = ky
9247  IF( incx.EQ.1 )THEN
9248  DO 100, j = 1, n
9249  temp = zero
9250  DO 90, i = 1, m
9251  temp = temp + a( i, j )*x( i )
9252  90 CONTINUE
9253  y( jy ) = y( jy ) + alpha*temp
9254  jy = jy + incy
9255  100 CONTINUE
9256  ELSE
9257  DO 120, j = 1, n
9258  temp = zero
9259  ix = kx
9260  DO 110, i = 1, m
9261  temp = temp + a( i, j )*x( ix )
9262  ix = ix + incx
9263  110 CONTINUE
9264  y( jy ) = y( jy ) + alpha*temp
9265  jy = jy + incy
9266  120 CONTINUE
9267  END IF
9268  END IF
9269 *
9270  RETURN
9271 *
9272 * End of DGEMV .
9273 *
9274  END
9275  SUBROUTINE dger ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
9276 * .. Scalar Arguments ..
9277  DOUBLE PRECISION ALPHA
9278  INTEGER INCX, INCY, LDA, M, N
9279 * .. Array Arguments ..
9280  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
9281 * ..
9282 *
9283 * Purpose
9284 * =======
9285 *
9286 * DGER performs the rank 1 operation
9287 *
9288 * A := alpha*x*y' + A,
9289 *
9290 * where alpha is a scalar, x is an m element vector, y is an n element
9291 * vector and A is an m by n matrix.
9292 *
9293 * Parameters
9294 * ==========
9295 *
9296 * M - INTEGER.
9297 * On entry, M specifies the number of rows of the matrix A.
9298 * M must be at least zero.
9299 * Unchanged on exit.
9300 *
9301 * N - INTEGER.
9302 * On entry, N specifies the number of columns of the matrix A.
9303 * N must be at least zero.
9304 * Unchanged on exit.
9305 *
9306 * ALPHA - DOUBLE PRECISION.
9307 * On entry, ALPHA specifies the scalar alpha.
9308 * Unchanged on exit.
9309 *
9310 * X - DOUBLE PRECISION array of dimension at least
9311 * ( 1 + ( m - 1 )*abs( INCX ) ).
9312 * Before entry, the incremented array X must contain the m
9313 * element vector x.
9314 * Unchanged on exit.
9315 *
9316 * INCX - INTEGER.
9317 * On entry, INCX specifies the increment for the elements of
9318 * X. INCX must not be zero.
9319 * Unchanged on exit.
9320 *
9321 * Y - DOUBLE PRECISION array of dimension at least
9322 * ( 1 + ( n - 1 )*abs( INCY ) ).
9323 * Before entry, the incremented array Y must contain the n
9324 * element vector y.
9325 * Unchanged on exit.
9326 *
9327 * INCY - INTEGER.
9328 * On entry, INCY specifies the increment for the elements of
9329 * Y. INCY must not be zero.
9330 * Unchanged on exit.
9331 *
9332 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
9333 * Before entry, the leading m by n part of the array A must
9334 * contain the matrix of coefficients. On exit, A is
9335 * overwritten by the updated matrix.
9336 *
9337 * LDA - INTEGER.
9338 * On entry, LDA specifies the first dimension of A as declared
9339 * in the calling (sub) program. LDA must be at least
9340 * max( 1, m ).
9341 * Unchanged on exit.
9342 *
9343 *
9344 * Level 2 Blas routine.
9345 *
9346 * -- Written on 22-October-1986.
9347 * Jack Dongarra, Argonne National Lab.
9348 * Jeremy Du Croz, Nag Central Office.
9349 * Sven Hammarling, Nag Central Office.
9350 * Richard Hanson, Sandia National Labs.
9351 *
9352 *
9353 * .. Parameters ..
9354  DOUBLE PRECISION ZERO
9355  parameter( zero = 0.0d+0 )
9356 * .. Local Scalars ..
9357  DOUBLE PRECISION TEMP
9358  INTEGER I, INFO, IX, J, JY, KX
9359 * .. External Subroutines ..
9360  EXTERNAL xerbla
9361 * .. Intrinsic Functions ..
9362  INTRINSIC max
9363 * ..
9364 * .. Executable Statements ..
9365 *
9366 * Test the input parameters.
9367 *
9368  info = 0
9369  IF ( m.LT.0 )THEN
9370  info = 1
9371  ELSE IF( n.LT.0 )THEN
9372  info = 2
9373  ELSE IF( incx.EQ.0 )THEN
9374  info = 5
9375  ELSE IF( incy.EQ.0 )THEN
9376  info = 7
9377  ELSE IF( lda.LT.max( 1, m ) )THEN
9378  info = 9
9379  END IF
9380  IF( info.NE.0 )THEN
9381  CALL xerbla( 'DGER ', info )
9382  RETURN
9383  END IF
9384 *
9385 * Quick return if possible.
9386 *
9387  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
9388  $ RETURN
9389 *
9390 * Start the operations. In this version the elements of A are
9391 * accessed sequentially with one pass through A.
9392 *
9393  IF( incy.GT.0 )THEN
9394  jy = 1
9395  ELSE
9396  jy = 1 - ( n - 1 )*incy
9397  END IF
9398  IF( incx.EQ.1 )THEN
9399  DO 20, j = 1, n
9400  IF( y( jy ).NE.zero )THEN
9401  temp = alpha*y( jy )
9402  DO 10, i = 1, m
9403  a( i, j ) = a( i, j ) + x( i )*temp
9404  10 CONTINUE
9405  END IF
9406  jy = jy + incy
9407  20 CONTINUE
9408  ELSE
9409  IF( incx.GT.0 )THEN
9410  kx = 1
9411  ELSE
9412  kx = 1 - ( m - 1 )*incx
9413  END IF
9414  DO 40, j = 1, n
9415  IF( y( jy ).NE.zero )THEN
9416  temp = alpha*y( jy )
9417  ix = kx
9418  DO 30, i = 1, m
9419  a( i, j ) = a( i, j ) + x( ix )*temp
9420  ix = ix + incx
9421  30 CONTINUE
9422  END IF
9423  jy = jy + incy
9424  40 CONTINUE
9425  END IF
9426 *
9427  RETURN
9428 *
9429 * End of DGER .
9430 *
9431  END
9432  DOUBLE PRECISION FUNCTION dnrm2 ( N, X, INCX )
9433 * .. Scalar Arguments ..
9434  INTEGER INCX, N
9435 * .. Array Arguments ..
9436  DOUBLE PRECISION X( * )
9437 * ..
9438 *
9439 * DNRM2 returns the euclidean norm of a vector via the function
9440 * name, so that
9441 *
9442 * DNRM2 := sqrt( x'*x )
9443 *
9444 *
9445 *
9446 * -- This version written on 25-October-1982.
9447 * Modified on 14-October-1993 to inline the call to DLASSQ.
9448 * Sven Hammarling, Nag Ltd.
9449 *
9450 *
9451 * .. Parameters ..
9452  DOUBLE PRECISION ONE , ZERO
9453  parameter( one = 1.0d+0, zero = 0.0d+0 )
9454 * .. Local Scalars ..
9455  INTEGER IX
9456  DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ
9457 * .. Intrinsic Functions ..
9458  INTRINSIC abs, sqrt
9459 * ..
9460 * .. Executable Statements ..
9461  IF( n.LT.1 .OR. incx.LT.1 )THEN
9462  norm = zero
9463  ELSE IF( n.EQ.1 )THEN
9464  norm = abs( x( 1 ) )
9465  ELSE
9466  scale = zero
9467  ssq = one
9468 * The following loop is equivalent to this call to the LAPACK
9469 * auxiliary routine:
9470 * CALL DLASSQ( N, X, INCX, SCALE, SSQ )
9471 *
9472  DO 10, ix = 1, 1 + ( n - 1 )*incx, incx
9473  IF( x( ix ).NE.zero )THEN
9474  absxi = abs( x( ix ) )
9475  IF( scale.LT.absxi )THEN
9476  ssq = one + ssq*( scale/absxi )**2
9477  scale = absxi
9478  ELSE
9479  ssq = ssq + ( absxi/scale )**2
9480  END IF
9481  END IF
9482  10 CONTINUE
9483  norm = scale * sqrt( ssq )
9484  END IF
9485 *
9486  dnrm2 = norm
9487  RETURN
9488 *
9489 * End of DNRM2.
9490 *
9491  END
9492  subroutine drot (n,dx,incx,dy,incy,c,s)
9493 c
9494 c applies a plane rotation.
9495 c jack dongarra, linpack, 3/11/78.
9496 c modified 12/3/93, array(1) declarations changed to array(*)
9497 c
9498  double precision dx(*),dy(*),dtemp,c,s
9499  integer i,incx,incy,ix,iy,n
9500 c
9501  if(n.le.0)return
9502  if(incx.eq.1.and.incy.eq.1)go to 20
9503 c
9504 c code for unequal increments or equal increments not equal
9505 c to 1
9506 c
9507  ix = 1
9508  iy = 1
9509  if(incx.lt.0)ix = (-n+1)*incx + 1
9510  if(incy.lt.0)iy = (-n+1)*incy + 1
9511  do 10 i = 1,n
9512  dtemp = c*dx(ix) + s*dy(iy)
9513  dy(iy) = c*dy(iy) - s*dx(ix)
9514  dx(ix) = dtemp
9515  ix = ix + incx
9516  iy = iy + incy
9517  10 continue
9518  return
9519 c
9520 c code for both increments equal to 1
9521 c
9522  20 do 30 i = 1,n
9523  dtemp = c*dx(i) + s*dy(i)
9524  dy(i) = c*dy(i) - s*dx(i)
9525  dx(i) = dtemp
9526  30 continue
9527  return
9528  end
9529  subroutine drotg(da,db,c,s)
9530 c
9531 c construct givens plane rotation.
9532 c jack dongarra, linpack, 3/11/78.
9533 c
9534  double precision da,db,c,s,roe,scale,r,z
9535 c
9536  roe = db
9537  if( dabs(da) .gt. dabs(db) ) roe = da
9538  scale = dabs(da) + dabs(db)
9539  if( scale .ne. 0.0d0 ) go to 10
9540  c = 1.0d0
9541  s = 0.0d0
9542  r = 0.0d0
9543  z = 0.0d0
9544  go to 20
9545  10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
9546  r = dsign(1.0d0,roe)*r
9547  c = da/r
9548  s = db/r
9549  z = 1.0d0
9550  if( dabs(da) .gt. dabs(db) ) z = s
9551  if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c
9552  20 da = r
9553  db = z
9554  return
9555  end
9556  SUBROUTINE drotm (N,DX,INCX,DY,INCY,DPARAM)
9557 C
9558 C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
9559 C
9560 C (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
9561 C (DY**T)
9562 C
9563 C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
9564 C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
9565 C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
9566 C
9567 C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
9568 C
9569 C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
9570 C H=( ) ( ) ( ) ( )
9571 C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
9572 C SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
9573 C
9574  DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21,
9575  1 dparam,dy,w,zero
9576  dimension dx(1),dy(1),dparam(5)
9577  DATA zero,two/0.d0,2.d0/
9578 C
9579  dflag=dparam(1)
9580  IF(n .LE. 0 .OR.(dflag+two.EQ.zero)) GO TO 140
9581  IF(.NOT.(incx.EQ.incy.AND. incx .GT.0)) GO TO 70
9582 C
9583  nsteps=n*incx
9584  IF(dflag) 50,10,30
9585  10 CONTINUE
9586  dh12=dparam(4)
9587  dh21=dparam(3)
9588  DO 20 i=1,nsteps,incx
9589  w=dx(i)
9590  z=dy(i)
9591  dx(i)=w+z*dh12
9592  dy(i)=w*dh21+z
9593  20 CONTINUE
9594  GO TO 140
9595  30 CONTINUE
9596  dh11=dparam(2)
9597  dh22=dparam(5)
9598  DO 40 i=1,nsteps,incx
9599  w=dx(i)
9600  z=dy(i)
9601  dx(i)=w*dh11+z
9602  dy(i)=-w+dh22*z
9603  40 CONTINUE
9604  GO TO 140
9605  50 CONTINUE
9606  dh11=dparam(2)
9607  dh12=dparam(4)
9608  dh21=dparam(3)
9609  dh22=dparam(5)
9610  DO 60 i=1,nsteps,incx
9611  w=dx(i)
9612  z=dy(i)
9613  dx(i)=w*dh11+z*dh12
9614  dy(i)=w*dh21+z*dh22
9615  60 CONTINUE
9616  GO TO 140
9617  70 CONTINUE
9618  kx=1
9619  ky=1
9620  IF(incx .LT. 0) kx=1+(1-n)*incx
9621  IF(incy .LT. 0) ky=1+(1-n)*incy
9622 C
9623  IF(dflag)120,80,100
9624  80 CONTINUE
9625  dh12=dparam(4)
9626  dh21=dparam(3)
9627  DO 90 i=1,n
9628  w=dx(kx)
9629  z=dy(ky)
9630  dx(kx)=w+z*dh12
9631  dy(ky)=w*dh21+z
9632  kx=kx+incx
9633  ky=ky+incy
9634  90 CONTINUE
9635  GO TO 140
9636  100 CONTINUE
9637  dh11=dparam(2)
9638  dh22=dparam(5)
9639  DO 110 i=1,n
9640  w=dx(kx)
9641  z=dy(ky)
9642  dx(kx)=w*dh11+z
9643  dy(ky)=-w+dh22*z
9644  kx=kx+incx
9645  ky=ky+incy
9646  110 CONTINUE
9647  GO TO 140
9648  120 CONTINUE
9649  dh11=dparam(2)
9650  dh12=dparam(4)
9651  dh21=dparam(3)
9652  dh22=dparam(5)
9653  DO 130 i=1,n
9654  w=dx(kx)
9655  z=dy(ky)
9656  dx(kx)=w*dh11+z*dh12
9657  dy(ky)=w*dh21+z*dh22
9658  kx=kx+incx
9659  ky=ky+incy
9660  130 CONTINUE
9661  140 CONTINUE
9662  RETURN
9663  END
9664  SUBROUTINE drotmg (DD1,DD2,DX1,DY1,DPARAM)
9665 C
9666 C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
9667 C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
9668 C DY2)**T.
9669 C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
9670 C
9671 C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
9672 C
9673 C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
9674 C H=( ) ( ) ( ) ( )
9675 C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
9676 C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
9677 C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
9678 C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
9679 C
9680 C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
9681 C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
9682 C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
9683 C
9684  DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
9685  1 dq2,du,dy1,zero,gamsq,dd1,dflag,dh12,dh22,dp1,dq1,
9686  2 dtemp,dx1,two
9687  dimension dparam(5)
9688 C
9689  DATA zero,one,two /0.d0,1.d0,2.d0/
9690  DATA gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
9691  IF(.NOT. dd1 .LT. zero) GO TO 10
9692 C GO ZERO-H-D-AND-DX1..
9693  GO TO 60
9694  10 CONTINUE
9695 C CASE-DD1-NONNEGATIVE
9696  dp2=dd2*dy1
9697  IF(.NOT. dp2 .EQ. zero) GO TO 20
9698  dflag=-two
9699  GO TO 260
9700 C REGULAR-CASE..
9701  20 CONTINUE
9702  dp1=dd1*dx1
9703  dq2=dp2*dy1
9704  dq1=dp1*dx1
9705 C
9706  IF(.NOT. dabs(dq1) .GT. dabs(dq2)) GO TO 40
9707  dh21=-dy1/dx1
9708  dh12=dp2/dp1
9709 C
9710  du=one-dh12*dh21
9711 C
9712  IF(.NOT. du .LE. zero) GO TO 30
9713 C GO ZERO-H-D-AND-DX1..
9714  GO TO 60
9715  30 CONTINUE
9716  dflag=zero
9717  dd1=dd1/du
9718  dd2=dd2/du
9719  dx1=dx1*du
9720 C GO SCALE-CHECK..
9721  GO TO 100
9722  40 CONTINUE
9723  IF(.NOT. dq2 .LT. zero) GO TO 50
9724 C GO ZERO-H-D-AND-DX1..
9725  GO TO 60
9726  50 CONTINUE
9727  dflag=one
9728  dh11=dp1/dp2
9729  dh22=dx1/dy1
9730  du=one+dh11*dh22
9731  dtemp=dd2/du
9732  dd2=dd1/du
9733  dd1=dtemp
9734  dx1=dy1*du
9735 C GO SCALE-CHECK
9736  GO TO 100
9737 C PROCEDURE..ZERO-H-D-AND-DX1..
9738  60 CONTINUE
9739  dflag=-one
9740  dh11=zero
9741  dh12=zero
9742  dh21=zero
9743  dh22=zero
9744 C
9745  dd1=zero
9746  dd2=zero
9747  dx1=zero
9748 C RETURN..
9749  GO TO 220
9750 C PROCEDURE..FIX-H..
9751  70 CONTINUE
9752  IF(.NOT. dflag .GE. zero) GO TO 90
9753 C
9754  IF(.NOT. dflag .EQ. zero) GO TO 80
9755  dh11=one
9756  dh22=one
9757  dflag=-one
9758  GO TO 90
9759  80 CONTINUE
9760  dh21=-one
9761  dh12=one
9762  dflag=-one
9763  90 CONTINUE
9764  GO TO igo,(120,150,180,210)
9765 C PROCEDURE..SCALE-CHECK
9766  100 CONTINUE
9767  110 CONTINUE
9768  IF(.NOT. dd1 .LE. rgamsq) GO TO 130
9769  IF(dd1 .EQ. zero) GO TO 160
9770  assign 120 to igo
9771 C FIX-H..
9772  GO TO 70
9773  120 CONTINUE
9774  dd1=dd1*gam**2
9775  dx1=dx1/gam
9776  dh11=dh11/gam
9777  dh12=dh12/gam
9778  GO TO 110
9779  130 CONTINUE
9780  140 CONTINUE
9781  IF(.NOT. dd1 .GE. gamsq) GO TO 160
9782  assign 150 to igo
9783 C FIX-H..
9784  GO TO 70
9785  150 CONTINUE
9786  dd1=dd1/gam**2
9787  dx1=dx1*gam
9788  dh11=dh11*gam
9789  dh12=dh12*gam
9790  GO TO 140
9791  160 CONTINUE
9792  170 CONTINUE
9793  IF(.NOT. dabs(dd2) .LE. rgamsq) GO TO 190
9794  IF(dd2 .EQ. zero) GO TO 220
9795  assign 180 to igo
9796 C FIX-H..
9797  GO TO 70
9798  180 CONTINUE
9799  dd2=dd2*gam**2
9800  dh21=dh21/gam
9801  dh22=dh22/gam
9802  GO TO 170
9803  190 CONTINUE
9804  200 CONTINUE
9805  IF(.NOT. dabs(dd2) .GE. gamsq) GO TO 220
9806  assign 210 to igo
9807 C FIX-H..
9808  GO TO 70
9809  210 CONTINUE
9810  dd2=dd2/gam**2
9811  dh21=dh21*gam
9812  dh22=dh22*gam
9813  GO TO 200
9814  220 CONTINUE
9815  IF(dflag)250,230,240
9816  230 CONTINUE
9817  dparam(3)=dh21
9818  dparam(4)=dh12
9819  GO TO 260
9820  240 CONTINUE
9821  dparam(2)=dh11
9822  dparam(5)=dh22
9823  GO TO 260
9824  250 CONTINUE
9825  dparam(2)=dh11
9826  dparam(3)=dh21
9827  dparam(4)=dh12
9828  dparam(5)=dh22
9829  260 CONTINUE
9830  dparam(1)=dflag
9831  RETURN
9832  END
9833  SUBROUTINE dsbmv ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
9834  $ beta, y, incy )
9835 * .. Scalar Arguments ..
9836  DOUBLE PRECISION ALPHA, BETA
9837  INTEGER INCX, INCY, K, LDA, N
9838  CHARACTER*1 UPLO
9839 * .. Array Arguments ..
9840  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
9841 * ..
9842 *
9843 * Purpose
9844 * =======
9845 *
9846 * DSBMV performs the matrix-vector operation
9847 *
9848 * y := alpha*A*x + beta*y,
9849 *
9850 * where alpha and beta are scalars, x and y are n element vectors and
9851 * A is an n by n symmetric band matrix, with k super-diagonals.
9852 *
9853 * Parameters
9854 * ==========
9855 *
9856 * UPLO - CHARACTER*1.
9857 * On entry, UPLO specifies whether the upper or lower
9858 * triangular part of the band matrix A is being supplied as
9859 * follows:
9860 *
9861 * UPLO = 'U' or 'u' The upper triangular part of A is
9862 * being supplied.
9863 *
9864 * UPLO = 'L' or 'l' The lower triangular part of A is
9865 * being supplied.
9866 *
9867 * Unchanged on exit.
9868 *
9869 * N - INTEGER.
9870 * On entry, N specifies the order of the matrix A.
9871 * N must be at least zero.
9872 * Unchanged on exit.
9873 *
9874 * K - INTEGER.
9875 * On entry, K specifies the number of super-diagonals of the
9876 * matrix A. K must satisfy 0 .le. K.
9877 * Unchanged on exit.
9878 *
9879 * ALPHA - DOUBLE PRECISION.
9880 * On entry, ALPHA specifies the scalar alpha.
9881 * Unchanged on exit.
9882 *
9883 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
9884 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
9885 * by n part of the array A must contain the upper triangular
9886 * band part of the symmetric matrix, supplied column by
9887 * column, with the leading diagonal of the matrix in row
9888 * ( k + 1 ) of the array, the first super-diagonal starting at
9889 * position 2 in row k, and so on. The top left k by k triangle
9890 * of the array A is not referenced.
9891 * The following program segment will transfer the upper
9892 * triangular part of a symmetric band matrix from conventional
9893 * full matrix storage to band storage:
9894 *
9895 * DO 20, J = 1, N
9896 * M = K + 1 - J
9897 * DO 10, I = MAX( 1, J - K ), J
9898 * A( M + I, J ) = matrix( I, J )
9899 * 10 CONTINUE
9900 * 20 CONTINUE
9901 *
9902 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
9903 * by n part of the array A must contain the lower triangular
9904 * band part of the symmetric matrix, supplied column by
9905 * column, with the leading diagonal of the matrix in row 1 of
9906 * the array, the first sub-diagonal starting at position 1 in
9907 * row 2, and so on. The bottom right k by k triangle of the
9908 * array A is not referenced.
9909 * The following program segment will transfer the lower
9910 * triangular part of a symmetric band matrix from conventional
9911 * full matrix storage to band storage:
9912 *
9913 * DO 20, J = 1, N
9914 * M = 1 - J
9915 * DO 10, I = J, MIN( N, J + K )
9916 * A( M + I, J ) = matrix( I, J )
9917 * 10 CONTINUE
9918 * 20 CONTINUE
9919 *
9920 * Unchanged on exit.
9921 *
9922 * LDA - INTEGER.
9923 * On entry, LDA specifies the first dimension of A as declared
9924 * in the calling (sub) program. LDA must be at least
9925 * ( k + 1 ).
9926 * Unchanged on exit.
9927 *
9928 * X - DOUBLE PRECISION array of DIMENSION at least
9929 * ( 1 + ( n - 1 )*abs( INCX ) ).
9930 * Before entry, the incremented array X must contain the
9931 * vector x.
9932 * Unchanged on exit.
9933 *
9934 * INCX - INTEGER.
9935 * On entry, INCX specifies the increment for the elements of
9936 * X. INCX must not be zero.
9937 * Unchanged on exit.
9938 *
9939 * BETA - DOUBLE PRECISION.
9940 * On entry, BETA specifies the scalar beta.
9941 * Unchanged on exit.
9942 *
9943 * Y - DOUBLE PRECISION array of DIMENSION at least
9944 * ( 1 + ( n - 1 )*abs( INCY ) ).
9945 * Before entry, the incremented array Y must contain the
9946 * vector y. On exit, Y is overwritten by the updated vector y.
9947 *
9948 * INCY - INTEGER.
9949 * On entry, INCY specifies the increment for the elements of
9950 * Y. INCY must not be zero.
9951 * Unchanged on exit.
9952 *
9953 *
9954 * Level 2 Blas routine.
9955 *
9956 * -- Written on 22-October-1986.
9957 * Jack Dongarra, Argonne National Lab.
9958 * Jeremy Du Croz, Nag Central Office.
9959 * Sven Hammarling, Nag Central Office.
9960 * Richard Hanson, Sandia National Labs.
9961 *
9962 *
9963 * .. Parameters ..
9964  DOUBLE PRECISION ONE , ZERO
9965  parameter( one = 1.0d+0, zero = 0.0d+0 )
9966 * .. Local Scalars ..
9967  DOUBLE PRECISION TEMP1, TEMP2
9968  INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
9969 * .. External Functions ..
9970  LOGICAL LSAME
9971  EXTERNAL lsame
9972 * .. External Subroutines ..
9973  EXTERNAL xerbla
9974 * .. Intrinsic Functions ..
9975  INTRINSIC max, min
9976 * ..
9977 * .. Executable Statements ..
9978 *
9979 * Test the input parameters.
9980 *
9981  info = 0
9982  IF ( .NOT.lsame( uplo, 'U' ).AND.
9983  $ .NOT.lsame( uplo, 'L' ) )THEN
9984  info = 1
9985  ELSE IF( n.LT.0 )THEN
9986  info = 2
9987  ELSE IF( k.LT.0 )THEN
9988  info = 3
9989  ELSE IF( lda.LT.( k + 1 ) )THEN
9990  info = 6
9991  ELSE IF( incx.EQ.0 )THEN
9992  info = 8
9993  ELSE IF( incy.EQ.0 )THEN
9994  info = 11
9995  END IF
9996  IF( info.NE.0 )THEN
9997  CALL xerbla( 'DSBMV ', info )
9998  RETURN
9999  END IF
10000 *
10001 * Quick return if possible.
10002 *
10003  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
10004  $ RETURN
10005 *
10006 * Set up the start points in X and Y.
10007 *
10008  IF( incx.GT.0 )THEN
10009  kx = 1
10010  ELSE
10011  kx = 1 - ( n - 1 )*incx
10012  END IF
10013  IF( incy.GT.0 )THEN
10014  ky = 1
10015  ELSE
10016  ky = 1 - ( n - 1 )*incy
10017  END IF
10018 *
10019 * Start the operations. In this version the elements of the array A
10020 * are accessed sequentially with one pass through A.
10021 *
10022 * First form y := beta*y.
10023 *
10024  IF( beta.NE.one )THEN
10025  IF( incy.EQ.1 )THEN
10026  IF( beta.EQ.zero )THEN
10027  DO 10, i = 1, n
10028  y( i ) = zero
10029  10 CONTINUE
10030  ELSE
10031  DO 20, i = 1, n
10032  y( i ) = beta*y( i )
10033  20 CONTINUE
10034  END IF
10035  ELSE
10036  iy = ky
10037  IF( beta.EQ.zero )THEN
10038  DO 30, i = 1, n
10039  y( iy ) = zero
10040  iy = iy + incy
10041  30 CONTINUE
10042  ELSE
10043  DO 40, i = 1, n
10044  y( iy ) = beta*y( iy )
10045  iy = iy + incy
10046  40 CONTINUE
10047  END IF
10048  END IF
10049  END IF
10050  IF( alpha.EQ.zero )
10051  $ RETURN
10052  IF( lsame( uplo, 'U' ) )THEN
10053 *
10054 * Form y when upper triangle of A is stored.
10055 *
10056  kplus1 = k + 1
10057  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10058  DO 60, j = 1, n
10059  temp1 = alpha*x( j )
10060  temp2 = zero
10061  l = kplus1 - j
10062  DO 50, i = max( 1, j - k ), j - 1
10063  y( i ) = y( i ) + temp1*a( l + i, j )
10064  temp2 = temp2 + a( l + i, j )*x( i )
10065  50 CONTINUE
10066  y( j ) = y( j ) + temp1*a( kplus1, j ) + alpha*temp2
10067  60 CONTINUE
10068  ELSE
10069  jx = kx
10070  jy = ky
10071  DO 80, j = 1, n
10072  temp1 = alpha*x( jx )
10073  temp2 = zero
10074  ix = kx
10075  iy = ky
10076  l = kplus1 - j
10077  DO 70, i = max( 1, j - k ), j - 1
10078  y( iy ) = y( iy ) + temp1*a( l + i, j )
10079  temp2 = temp2 + a( l + i, j )*x( ix )
10080  ix = ix + incx
10081  iy = iy + incy
10082  70 CONTINUE
10083  y( jy ) = y( jy ) + temp1*a( kplus1, j ) + alpha*temp2
10084  jx = jx + incx
10085  jy = jy + incy
10086  IF( j.GT.k )THEN
10087  kx = kx + incx
10088  ky = ky + incy
10089  END IF
10090  80 CONTINUE
10091  END IF
10092  ELSE
10093 *
10094 * Form y when lower triangle of A is stored.
10095 *
10096  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10097  DO 100, j = 1, n
10098  temp1 = alpha*x( j )
10099  temp2 = zero
10100  y( j ) = y( j ) + temp1*a( 1, j )
10101  l = 1 - j
10102  DO 90, i = j + 1, min( n, j + k )
10103  y( i ) = y( i ) + temp1*a( l + i, j )
10104  temp2 = temp2 + a( l + i, j )*x( i )
10105  90 CONTINUE
10106  y( j ) = y( j ) + alpha*temp2
10107  100 CONTINUE
10108  ELSE
10109  jx = kx
10110  jy = ky
10111  DO 120, j = 1, n
10112  temp1 = alpha*x( jx )
10113  temp2 = zero
10114  y( jy ) = y( jy ) + temp1*a( 1, j )
10115  l = 1 - j
10116  ix = jx
10117  iy = jy
10118  DO 110, i = j + 1, min( n, j + k )
10119  ix = ix + incx
10120  iy = iy + incy
10121  y( iy ) = y( iy ) + temp1*a( l + i, j )
10122  temp2 = temp2 + a( l + i, j )*x( ix )
10123  110 CONTINUE
10124  y( jy ) = y( jy ) + alpha*temp2
10125  jx = jx + incx
10126  jy = jy + incy
10127  120 CONTINUE
10128  END IF
10129  END IF
10130 *
10131  RETURN
10132 *
10133 * End of DSBMV .
10134 *
10135  END
10136  subroutine dscal(n,da,dx,incx)
10137 c
10138 c scales a vector by a constant.
10139 c uses unrolled loops for increment equal to one.
10140 c jack dongarra, linpack, 3/11/78.
10141 c modified 3/93 to return if incx .le. 0.
10142 c modified 12/3/93, array(1) declarations changed to array(*)
10143 c
10144  double precision da,dx(*)
10145  integer i,incx,m,mp1,n,nincx
10146 c
10147  if( n.le.0 .or. incx.le.0 )return
10148  if(incx.eq.1)go to 20
10149 c
10150 c code for increment not equal to 1
10151 c
10152  nincx = n*incx
10153  do 10 i = 1,nincx,incx
10154  dx(i) = da*dx(i)
10155  10 continue
10156  return
10157 c
10158 c code for increment equal to 1
10159 c
10160 c
10161 c clean-up loop
10162 c
10163  20 m = mod(n,5)
10164  if( m .eq. 0 ) go to 40
10165  do 30 i = 1,m
10166  dx(i) = da*dx(i)
10167  30 continue
10168  if( n .lt. 5 ) return
10169  40 mp1 = m + 1
10170  do 50 i = mp1,n,5
10171  dx(i) = da*dx(i)
10172  dx(i + 1) = da*dx(i + 1)
10173  dx(i + 2) = da*dx(i + 2)
10174  dx(i + 3) = da*dx(i + 3)
10175  dx(i + 4) = da*dx(i + 4)
10176  50 continue
10177  return
10178  end
10179 *DECK DSDOT
10180  DOUBLE PRECISION FUNCTION dsdot (N, SX, INCX, SY, INCY)
10181 C***BEGIN PROLOGUE DSDOT
10182 C***PURPOSE Compute the inner product of two vectors with extended
10183 C precision accumulation and result.
10184 C***LIBRARY SLATEC (BLAS)
10185 C***CATEGORY D1A4
10186 C***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C)
10187 C***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT,
10188 C LINEAR ALGEBRA, VECTOR
10189 C***AUTHOR Lawson, C. L., (JPL)
10190 C Hanson, R. J., (SNLA)
10191 C Kincaid, D. R., (U. of Texas)
10192 C Krogh, F. T., (JPL)
10193 C***DESCRIPTION
10194 C
10195 C B L A S Subprogram
10196 C Description of Parameters
10197 C
10198 C --Input--
10199 C N number of elements in input vector(s)
10200 C SX single precision vector with N elements
10201 C INCX storage spacing between elements of SX
10202 C SY single precision vector with N elements
10203 C INCY storage spacing between elements of SY
10204 C
10205 C --Output--
10206 C DSDOT double precision dot product (zero if N.LE.0)
10207 C
10208 C Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
10209 C DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY),
10210 C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
10211 C defined in a similar way using INCY.
10212 C
10213 C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
10214 C Krogh, Basic linear algebra subprograms for Fortran
10215 C usage, Algorithm No. 539, Transactions on Mathematical
10216 C Software 5, 3 (September 1979), pp. 308-323.
10217 C***ROUTINES CALLED (NONE)
10218 C***REVISION HISTORY (YYMMDD)
10219 C 791001 DATE WRITTEN
10220 C 890831 Modified array declarations. (WRB)
10221 C 890831 REVISION DATE from Version 3.2
10222 C 891214 Prologue converted to Version 4.0 format. (BAB)
10223 C 920310 Corrected definition of LX in DESCRIPTION. (WRB)
10224 C 920501 Reformatted the REFERENCES section. (WRB)
10225 C***END PROLOGUE DSDOT
10226  REAL SX(*),SY(*)
10227 C***FIRST EXECUTABLE STATEMENT DSDOT
10228  dsdot = 0.0d0
10229  IF (n .LE. 0) RETURN
10230  IF (incx.EQ.incy .AND. incx.GT.0) GO TO 20
10231 C
10232 C Code for unequal or nonpositive increments.
10233 C
10234  kx = 1
10235  ky = 1
10236  IF (incx .LT. 0) kx = 1+(1-n)*incx
10237  IF (incy .LT. 0) ky = 1+(1-n)*incy
10238  DO 10 i = 1,n
10239  dsdot = dsdot + dble(sx(kx))*dble(sy(ky))
10240  kx = kx + incx
10241  ky = ky + incy
10242  10 CONTINUE
10243  RETURN
10244 C
10245 C Code for equal, positive, non-unit increments.
10246 C
10247  20 ns = n*incx
10248  DO 30 i = 1,ns,incx
10249  dsdot = dsdot + dble(sx(i))*dble(sy(i))
10250  30 CONTINUE
10251  RETURN
10252  END
10253  SUBROUTINE dspmv ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
10254 * .. Scalar Arguments ..
10255  DOUBLE PRECISION ALPHA, BETA
10256  INTEGER INCX, INCY, N
10257  CHARACTER*1 UPLO
10258 * .. Array Arguments ..
10259  DOUBLE PRECISION AP( * ), X( * ), Y( * )
10260 * ..
10261 *
10262 * Purpose
10263 * =======
10264 *
10265 * DSPMV performs the matrix-vector operation
10266 *
10267 * y := alpha*A*x + beta*y,
10268 *
10269 * where alpha and beta are scalars, x and y are n element vectors and
10270 * A is an n by n symmetric matrix, supplied in packed form.
10271 *
10272 * Parameters
10273 * ==========
10274 *
10275 * UPLO - CHARACTER*1.
10276 * On entry, UPLO specifies whether the upper or lower
10277 * triangular part of the matrix A is supplied in the packed
10278 * array AP as follows:
10279 *
10280 * UPLO = 'U' or 'u' The upper triangular part of A is
10281 * supplied in AP.
10282 *
10283 * UPLO = 'L' or 'l' The lower triangular part of A is
10284 * supplied in AP.
10285 *
10286 * Unchanged on exit.
10287 *
10288 * N - INTEGER.
10289 * On entry, N specifies the order of the matrix A.
10290 * N must be at least zero.
10291 * Unchanged on exit.
10292 *
10293 * ALPHA - DOUBLE PRECISION.
10294 * On entry, ALPHA specifies the scalar alpha.
10295 * Unchanged on exit.
10296 *
10297 * AP - DOUBLE PRECISION array of DIMENSION at least
10298 * ( ( n*( n + 1 ) )/2 ).
10299 * Before entry with UPLO = 'U' or 'u', the array AP must
10300 * contain the upper triangular part of the symmetric matrix
10301 * packed sequentially, column by column, so that AP( 1 )
10302 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
10303 * and a( 2, 2 ) respectively, and so on.
10304 * Before entry with UPLO = 'L' or 'l', the array AP must
10305 * contain the lower triangular part of the symmetric matrix
10306 * packed sequentially, column by column, so that AP( 1 )
10307 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
10308 * and a( 3, 1 ) respectively, and so on.
10309 * Unchanged on exit.
10310 *
10311 * X - DOUBLE PRECISION array of dimension at least
10312 * ( 1 + ( n - 1 )*abs( INCX ) ).
10313 * Before entry, the incremented array X must contain the n
10314 * element vector x.
10315 * Unchanged on exit.
10316 *
10317 * INCX - INTEGER.
10318 * On entry, INCX specifies the increment for the elements of
10319 * X. INCX must not be zero.
10320 * Unchanged on exit.
10321 *
10322 * BETA - DOUBLE PRECISION.
10323 * On entry, BETA specifies the scalar beta. When BETA is
10324 * supplied as zero then Y need not be set on input.
10325 * Unchanged on exit.
10326 *
10327 * Y - DOUBLE PRECISION array of dimension at least
10328 * ( 1 + ( n - 1 )*abs( INCY ) ).
10329 * Before entry, the incremented array Y must contain the n
10330 * element vector y. On exit, Y is overwritten by the updated
10331 * vector y.
10332 *
10333 * INCY - INTEGER.
10334 * On entry, INCY specifies the increment for the elements of
10335 * Y. INCY must not be zero.
10336 * Unchanged on exit.
10337 *
10338 *
10339 * Level 2 Blas routine.
10340 *
10341 * -- Written on 22-October-1986.
10342 * Jack Dongarra, Argonne National Lab.
10343 * Jeremy Du Croz, Nag Central Office.
10344 * Sven Hammarling, Nag Central Office.
10345 * Richard Hanson, Sandia National Labs.
10346 *
10347 *
10348 * .. Parameters ..
10349  DOUBLE PRECISION ONE , ZERO
10350  parameter( one = 1.0d+0, zero = 0.0d+0 )
10351 * .. Local Scalars ..
10352  DOUBLE PRECISION TEMP1, TEMP2
10353  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
10354 * .. External Functions ..
10355  LOGICAL LSAME
10356  EXTERNAL lsame
10357 * .. External Subroutines ..
10358  EXTERNAL xerbla
10359 * ..
10360 * .. Executable Statements ..
10361 *
10362 * Test the input parameters.
10363 *
10364  info = 0
10365  IF ( .NOT.lsame( uplo, 'U' ).AND.
10366  $ .NOT.lsame( uplo, 'L' ) )THEN
10367  info = 1
10368  ELSE IF( n.LT.0 )THEN
10369  info = 2
10370  ELSE IF( incx.EQ.0 )THEN
10371  info = 6
10372  ELSE IF( incy.EQ.0 )THEN
10373  info = 9
10374  END IF
10375  IF( info.NE.0 )THEN
10376  CALL xerbla( 'DSPMV ', info )
10377  RETURN
10378  END IF
10379 *
10380 * Quick return if possible.
10381 *
10382  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
10383  $ RETURN
10384 *
10385 * Set up the start points in X and Y.
10386 *
10387  IF( incx.GT.0 )THEN
10388  kx = 1
10389  ELSE
10390  kx = 1 - ( n - 1 )*incx
10391  END IF
10392  IF( incy.GT.0 )THEN
10393  ky = 1
10394  ELSE
10395  ky = 1 - ( n - 1 )*incy
10396  END IF
10397 *
10398 * Start the operations. In this version the elements of the array AP
10399 * are accessed sequentially with one pass through AP.
10400 *
10401 * First form y := beta*y.
10402 *
10403  IF( beta.NE.one )THEN
10404  IF( incy.EQ.1 )THEN
10405  IF( beta.EQ.zero )THEN
10406  DO 10, i = 1, n
10407  y( i ) = zero
10408  10 CONTINUE
10409  ELSE
10410  DO 20, i = 1, n
10411  y( i ) = beta*y( i )
10412  20 CONTINUE
10413  END IF
10414  ELSE
10415  iy = ky
10416  IF( beta.EQ.zero )THEN
10417  DO 30, i = 1, n
10418  y( iy ) = zero
10419  iy = iy + incy
10420  30 CONTINUE
10421  ELSE
10422  DO 40, i = 1, n
10423  y( iy ) = beta*y( iy )
10424  iy = iy + incy
10425  40 CONTINUE
10426  END IF
10427  END IF
10428  END IF
10429  IF( alpha.EQ.zero )
10430  $ RETURN
10431  kk = 1
10432  IF( lsame( uplo, 'U' ) )THEN
10433 *
10434 * Form y when AP contains the upper triangle.
10435 *
10436  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10437  DO 60, j = 1, n
10438  temp1 = alpha*x( j )
10439  temp2 = zero
10440  k = kk
10441  DO 50, i = 1, j - 1
10442  y( i ) = y( i ) + temp1*ap( k )
10443  temp2 = temp2 + ap( k )*x( i )
10444  k = k + 1
10445  50 CONTINUE
10446  y( j ) = y( j ) + temp1*ap( kk + j - 1 ) + alpha*temp2
10447  kk = kk + j
10448  60 CONTINUE
10449  ELSE
10450  jx = kx
10451  jy = ky
10452  DO 80, j = 1, n
10453  temp1 = alpha*x( jx )
10454  temp2 = zero
10455  ix = kx
10456  iy = ky
10457  DO 70, k = kk, kk + j - 2
10458  y( iy ) = y( iy ) + temp1*ap( k )
10459  temp2 = temp2 + ap( k )*x( ix )
10460  ix = ix + incx
10461  iy = iy + incy
10462  70 CONTINUE
10463  y( jy ) = y( jy ) + temp1*ap( kk + j - 1 ) + alpha*temp2
10464  jx = jx + incx
10465  jy = jy + incy
10466  kk = kk + j
10467  80 CONTINUE
10468  END IF
10469  ELSE
10470 *
10471 * Form y when AP contains the lower triangle.
10472 *
10473  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10474  DO 100, j = 1, n
10475  temp1 = alpha*x( j )
10476  temp2 = zero
10477  y( j ) = y( j ) + temp1*ap( kk )
10478  k = kk + 1
10479  DO 90, i = j + 1, n
10480  y( i ) = y( i ) + temp1*ap( k )
10481  temp2 = temp2 + ap( k )*x( i )
10482  k = k + 1
10483  90 CONTINUE
10484  y( j ) = y( j ) + alpha*temp2
10485  kk = kk + ( n - j + 1 )
10486  100 CONTINUE
10487  ELSE
10488  jx = kx
10489  jy = ky
10490  DO 120, j = 1, n
10491  temp1 = alpha*x( jx )
10492  temp2 = zero
10493  y( jy ) = y( jy ) + temp1*ap( kk )
10494  ix = jx
10495  iy = jy
10496  DO 110, k = kk + 1, kk + n - j
10497  ix = ix + incx
10498  iy = iy + incy
10499  y( iy ) = y( iy ) + temp1*ap( k )
10500  temp2 = temp2 + ap( k )*x( ix )
10501  110 CONTINUE
10502  y( jy ) = y( jy ) + alpha*temp2
10503  jx = jx + incx
10504  jy = jy + incy
10505  kk = kk + ( n - j + 1 )
10506  120 CONTINUE
10507  END IF
10508  END IF
10509 *
10510  RETURN
10511 *
10512 * End of DSPMV .
10513 *
10514  END
10515  SUBROUTINE dspr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
10516 * .. Scalar Arguments ..
10517  DOUBLE PRECISION ALPHA
10518  INTEGER INCX, INCY, N
10519  CHARACTER*1 UPLO
10520 * .. Array Arguments ..
10521  DOUBLE PRECISION AP( * ), X( * ), Y( * )
10522 * ..
10523 *
10524 * Purpose
10525 * =======
10526 *
10527 * DSPR2 performs the symmetric rank 2 operation
10528 *
10529 * A := alpha*x*y' + alpha*y*x' + A,
10530 *
10531 * where alpha is a scalar, x and y are n element vectors and A is an
10532 * n by n symmetric matrix, supplied in packed form.
10533 *
10534 * Parameters
10535 * ==========
10536 *
10537 * UPLO - CHARACTER*1.
10538 * On entry, UPLO specifies whether the upper or lower
10539 * triangular part of the matrix A is supplied in the packed
10540 * array AP as follows:
10541 *
10542 * UPLO = 'U' or 'u' The upper triangular part of A is
10543 * supplied in AP.
10544 *
10545 * UPLO = 'L' or 'l' The lower triangular part of A is
10546 * supplied in AP.
10547 *
10548 * Unchanged on exit.
10549 *
10550 * N - INTEGER.
10551 * On entry, N specifies the order of the matrix A.
10552 * N must be at least zero.
10553 * Unchanged on exit.
10554 *
10555 * ALPHA - DOUBLE PRECISION.
10556 * On entry, ALPHA specifies the scalar alpha.
10557 * Unchanged on exit.
10558 *
10559 * X - DOUBLE PRECISION array of dimension at least
10560 * ( 1 + ( n - 1 )*abs( INCX ) ).
10561 * Before entry, the incremented array X must contain the n
10562 * element vector x.
10563 * Unchanged on exit.
10564 *
10565 * INCX - INTEGER.
10566 * On entry, INCX specifies the increment for the elements of
10567 * X. INCX must not be zero.
10568 * Unchanged on exit.
10569 *
10570 * Y - DOUBLE PRECISION array of dimension at least
10571 * ( 1 + ( n - 1 )*abs( INCY ) ).
10572 * Before entry, the incremented array Y must contain the n
10573 * element vector y.
10574 * Unchanged on exit.
10575 *
10576 * INCY - INTEGER.
10577 * On entry, INCY specifies the increment for the elements of
10578 * Y. INCY must not be zero.
10579 * Unchanged on exit.
10580 *
10581 * AP - DOUBLE PRECISION array of DIMENSION at least
10582 * ( ( n*( n + 1 ) )/2 ).
10583 * Before entry with UPLO = 'U' or 'u', the array AP must
10584 * contain the upper triangular part of the symmetric matrix
10585 * packed sequentially, column by column, so that AP( 1 )
10586 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
10587 * and a( 2, 2 ) respectively, and so on. On exit, the array
10588 * AP is overwritten by the upper triangular part of the
10589 * updated matrix.
10590 * Before entry with UPLO = 'L' or 'l', the array AP must
10591 * contain the lower triangular part of the symmetric matrix
10592 * packed sequentially, column by column, so that AP( 1 )
10593 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
10594 * and a( 3, 1 ) respectively, and so on. On exit, the array
10595 * AP is overwritten by the lower triangular part of the
10596 * updated matrix.
10597 *
10598 *
10599 * Level 2 Blas routine.
10600 *
10601 * -- Written on 22-October-1986.
10602 * Jack Dongarra, Argonne National Lab.
10603 * Jeremy Du Croz, Nag Central Office.
10604 * Sven Hammarling, Nag Central Office.
10605 * Richard Hanson, Sandia National Labs.
10606 *
10607 *
10608 * .. Parameters ..
10609  DOUBLE PRECISION ZERO
10610  parameter( zero = 0.0d+0 )
10611 * .. Local Scalars ..
10612  DOUBLE PRECISION TEMP1, TEMP2
10613  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
10614 * .. External Functions ..
10615  LOGICAL LSAME
10616  EXTERNAL lsame
10617 * .. External Subroutines ..
10618  EXTERNAL xerbla
10619 * ..
10620 * .. Executable Statements ..
10621 *
10622 * Test the input parameters.
10623 *
10624  info = 0
10625  IF ( .NOT.lsame( uplo, 'U' ).AND.
10626  $ .NOT.lsame( uplo, 'L' ) )THEN
10627  info = 1
10628  ELSE IF( n.LT.0 )THEN
10629  info = 2
10630  ELSE IF( incx.EQ.0 )THEN
10631  info = 5
10632  ELSE IF( incy.EQ.0 )THEN
10633  info = 7
10634  END IF
10635  IF( info.NE.0 )THEN
10636  CALL xerbla( 'DSPR2 ', info )
10637  RETURN
10638  END IF
10639 *
10640 * Quick return if possible.
10641 *
10642  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
10643  $ RETURN
10644 *
10645 * Set up the start points in X and Y if the increments are not both
10646 * unity.
10647 *
10648  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
10649  IF( incx.GT.0 )THEN
10650  kx = 1
10651  ELSE
10652  kx = 1 - ( n - 1 )*incx
10653  END IF
10654  IF( incy.GT.0 )THEN
10655  ky = 1
10656  ELSE
10657  ky = 1 - ( n - 1 )*incy
10658  END IF
10659  jx = kx
10660  jy = ky
10661  END IF
10662 *
10663 * Start the operations. In this version the elements of the array AP
10664 * are accessed sequentially with one pass through AP.
10665 *
10666  kk = 1
10667  IF( lsame( uplo, 'U' ) )THEN
10668 *
10669 * Form A when upper triangle is stored in AP.
10670 *
10671  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10672  DO 20, j = 1, n
10673  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
10674  temp1 = alpha*y( j )
10675  temp2 = alpha*x( j )
10676  k = kk
10677  DO 10, i = 1, j
10678  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
10679  k = k + 1
10680  10 CONTINUE
10681  END IF
10682  kk = kk + j
10683  20 CONTINUE
10684  ELSE
10685  DO 40, j = 1, n
10686  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
10687  temp1 = alpha*y( jy )
10688  temp2 = alpha*x( jx )
10689  ix = kx
10690  iy = ky
10691  DO 30, k = kk, kk + j - 1
10692  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
10693  ix = ix + incx
10694  iy = iy + incy
10695  30 CONTINUE
10696  END IF
10697  jx = jx + incx
10698  jy = jy + incy
10699  kk = kk + j
10700  40 CONTINUE
10701  END IF
10702  ELSE
10703 *
10704 * Form A when lower triangle is stored in AP.
10705 *
10706  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
10707  DO 60, j = 1, n
10708  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
10709  temp1 = alpha*y( j )
10710  temp2 = alpha*x( j )
10711  k = kk
10712  DO 50, i = j, n
10713  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
10714  k = k + 1
10715  50 CONTINUE
10716  END IF
10717  kk = kk + n - j + 1
10718  60 CONTINUE
10719  ELSE
10720  DO 80, j = 1, n
10721  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
10722  temp1 = alpha*y( jy )
10723  temp2 = alpha*x( jx )
10724  ix = jx
10725  iy = jy
10726  DO 70, k = kk, kk + n - j
10727  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
10728  ix = ix + incx
10729  iy = iy + incy
10730  70 CONTINUE
10731  END IF
10732  jx = jx + incx
10733  jy = jy + incy
10734  kk = kk + n - j + 1
10735  80 CONTINUE
10736  END IF
10737  END IF
10738 *
10739  RETURN
10740 *
10741 * End of DSPR2 .
10742 *
10743  END
10744  SUBROUTINE dspr ( UPLO, N, ALPHA, X, INCX, AP )
10745 * .. Scalar Arguments ..
10746  DOUBLE PRECISION ALPHA
10747  INTEGER INCX, N
10748  CHARACTER*1 UPLO
10749 * .. Array Arguments ..
10750  DOUBLE PRECISION AP( * ), X( * )
10751 * ..
10752 *
10753 * Purpose
10754 * =======
10755 *
10756 * DSPR performs the symmetric rank 1 operation
10757 *
10758 * A := alpha*x*x' + A,
10759 *
10760 * where alpha is a real scalar, x is an n element vector and A is an
10761 * n by n symmetric matrix, supplied in packed form.
10762 *
10763 * Parameters
10764 * ==========
10765 *
10766 * UPLO - CHARACTER*1.
10767 * On entry, UPLO specifies whether the upper or lower
10768 * triangular part of the matrix A is supplied in the packed
10769 * array AP as follows:
10770 *
10771 * UPLO = 'U' or 'u' The upper triangular part of A is
10772 * supplied in AP.
10773 *
10774 * UPLO = 'L' or 'l' The lower triangular part of A is
10775 * supplied in AP.
10776 *
10777 * Unchanged on exit.
10778 *
10779 * N - INTEGER.
10780 * On entry, N specifies the order of the matrix A.
10781 * N must be at least zero.
10782 * Unchanged on exit.
10783 *
10784 * ALPHA - DOUBLE PRECISION.
10785 * On entry, ALPHA specifies the scalar alpha.
10786 * Unchanged on exit.
10787 *
10788 * X - DOUBLE PRECISION array of dimension at least
10789 * ( 1 + ( n - 1 )*abs( INCX ) ).
10790 * Before entry, the incremented array X must contain the n
10791 * element vector x.
10792 * Unchanged on exit.
10793 *
10794 * INCX - INTEGER.
10795 * On entry, INCX specifies the increment for the elements of
10796 * X. INCX must not be zero.
10797 * Unchanged on exit.
10798 *
10799 * AP - DOUBLE PRECISION array of DIMENSION at least
10800 * ( ( n*( n + 1 ) )/2 ).
10801 * Before entry with UPLO = 'U' or 'u', the array AP must
10802 * contain the upper triangular part of the symmetric matrix
10803 * packed sequentially, column by column, so that AP( 1 )
10804 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
10805 * and a( 2, 2 ) respectively, and so on. On exit, the array
10806 * AP is overwritten by the upper triangular part of the
10807 * updated matrix.
10808 * Before entry with UPLO = 'L' or 'l', the array AP must
10809 * contain the lower triangular part of the symmetric matrix
10810 * packed sequentially, column by column, so that AP( 1 )
10811 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
10812 * and a( 3, 1 ) respectively, and so on. On exit, the array
10813 * AP is overwritten by the lower triangular part of the
10814 * updated matrix.
10815 *
10816 *
10817 * Level 2 Blas routine.
10818 *
10819 * -- Written on 22-October-1986.
10820 * Jack Dongarra, Argonne National Lab.
10821 * Jeremy Du Croz, Nag Central Office.
10822 * Sven Hammarling, Nag Central Office.
10823 * Richard Hanson, Sandia National Labs.
10824 *
10825 *
10826 * .. Parameters ..
10827  DOUBLE PRECISION ZERO
10828  parameter( zero = 0.0d+0 )
10829 * .. Local Scalars ..
10830  DOUBLE PRECISION TEMP
10831  INTEGER I, INFO, IX, J, JX, K, KK, KX
10832 * .. External Functions ..
10833  LOGICAL LSAME
10834  EXTERNAL lsame
10835 * .. External Subroutines ..
10836  EXTERNAL xerbla
10837 * ..
10838 * .. Executable Statements ..
10839 *
10840 * Test the input parameters.
10841 *
10842  info = 0
10843  IF ( .NOT.lsame( uplo, 'U' ).AND.
10844  $ .NOT.lsame( uplo, 'L' ) )THEN
10845  info = 1
10846  ELSE IF( n.LT.0 )THEN
10847  info = 2
10848  ELSE IF( incx.EQ.0 )THEN
10849  info = 5
10850  END IF
10851  IF( info.NE.0 )THEN
10852  CALL xerbla( 'DSPR ', info )
10853  RETURN
10854  END IF
10855 *
10856 * Quick return if possible.
10857 *
10858  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
10859  $ RETURN
10860 *
10861 * Set the start point in X if the increment is not unity.
10862 *
10863  IF( incx.LE.0 )THEN
10864  kx = 1 - ( n - 1 )*incx
10865  ELSE IF( incx.NE.1 )THEN
10866  kx = 1
10867  END IF
10868 *
10869 * Start the operations. In this version the elements of the array AP
10870 * are accessed sequentially with one pass through AP.
10871 *
10872  kk = 1
10873  IF( lsame( uplo, 'U' ) )THEN
10874 *
10875 * Form A when upper triangle is stored in AP.
10876 *
10877  IF( incx.EQ.1 )THEN
10878  DO 20, j = 1, n
10879  IF( x( j ).NE.zero )THEN
10880  temp = alpha*x( j )
10881  k = kk
10882  DO 10, i = 1, j
10883  ap( k ) = ap( k ) + x( i )*temp
10884  k = k + 1
10885  10 CONTINUE
10886  END IF
10887  kk = kk + j
10888  20 CONTINUE
10889  ELSE
10890  jx = kx
10891  DO 40, j = 1, n
10892  IF( x( jx ).NE.zero )THEN
10893  temp = alpha*x( jx )
10894  ix = kx
10895  DO 30, k = kk, kk + j - 1
10896  ap( k ) = ap( k ) + x( ix )*temp
10897  ix = ix + incx
10898  30 CONTINUE
10899  END IF
10900  jx = jx + incx
10901  kk = kk + j
10902  40 CONTINUE
10903  END IF
10904  ELSE
10905 *
10906 * Form A when lower triangle is stored in AP.
10907 *
10908  IF( incx.EQ.1 )THEN
10909  DO 60, j = 1, n
10910  IF( x( j ).NE.zero )THEN
10911  temp = alpha*x( j )
10912  k = kk
10913  DO 50, i = j, n
10914  ap( k ) = ap( k ) + x( i )*temp
10915  k = k + 1
10916  50 CONTINUE
10917  END IF
10918  kk = kk + n - j + 1
10919  60 CONTINUE
10920  ELSE
10921  jx = kx
10922  DO 80, j = 1, n
10923  IF( x( jx ).NE.zero )THEN
10924  temp = alpha*x( jx )
10925  ix = jx
10926  DO 70, k = kk, kk + n - j
10927  ap( k ) = ap( k ) + x( ix )*temp
10928  ix = ix + incx
10929  70 CONTINUE
10930  END IF
10931  jx = jx + incx
10932  kk = kk + n - j + 1
10933  80 CONTINUE
10934  END IF
10935  END IF
10936 *
10937  RETURN
10938 *
10939 * End of DSPR .
10940 *
10941  END
10942  subroutine dswap (n,dx,incx,dy,incy)
10943 c
10944 c interchanges two vectors.
10945 c uses unrolled loops for increments equal one.
10946 c jack dongarra, linpack, 3/11/78.
10947 c modified 12/3/93, array(1) declarations changed to array(*)
10948 c
10949  double precision dx(*),dy(*),dtemp
10950  integer i,incx,incy,ix,iy,m,mp1,n
10951 c
10952  if(n.le.0)return
10953  if(incx.eq.1.and.incy.eq.1)go to 20
10954 c
10955 c code for unequal increments or equal increments not equal
10956 c to 1
10957 c
10958  ix = 1
10959  iy = 1
10960  if(incx.lt.0)ix = (-n+1)*incx + 1
10961  if(incy.lt.0)iy = (-n+1)*incy + 1
10962  do 10 i = 1,n
10963  dtemp = dx(ix)
10964  dx(ix) = dy(iy)
10965  dy(iy) = dtemp
10966  ix = ix + incx
10967  iy = iy + incy
10968  10 continue
10969  return
10970 c
10971 c code for both increments equal to 1
10972 c
10973 c
10974 c clean-up loop
10975 c
10976  20 m = mod(n,3)
10977  if( m .eq. 0 ) go to 40
10978  do 30 i = 1,m
10979  dtemp = dx(i)
10980  dx(i) = dy(i)
10981  dy(i) = dtemp
10982  30 continue
10983  if( n .lt. 3 ) return
10984  40 mp1 = m + 1
10985  do 50 i = mp1,n,3
10986  dtemp = dx(i)
10987  dx(i) = dy(i)
10988  dy(i) = dtemp
10989  dtemp = dx(i + 1)
10990  dx(i + 1) = dy(i + 1)
10991  dy(i + 1) = dtemp
10992  dtemp = dx(i + 2)
10993  dx(i + 2) = dy(i + 2)
10994  dy(i + 2) = dtemp
10995  50 continue
10996  return
10997  end
10998  SUBROUTINE dsymm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
10999  $ beta, c, ldc )
11000 * .. Scalar Arguments ..
11001  CHARACTER*1 SIDE, UPLO
11002  INTEGER M, N, LDA, LDB, LDC
11003  DOUBLE PRECISION ALPHA, BETA
11004 * .. Array Arguments ..
11005  DOUBLE PRECISION A( lda, * ), B( ldb, * ), C( ldc, * )
11006 * ..
11007 *
11008 * Purpose
11009 * =======
11010 *
11011 * DSYMM performs one of the matrix-matrix operations
11012 *
11013 * C := alpha*A*B + beta*C,
11014 *
11015 * or
11016 *
11017 * C := alpha*B*A + beta*C,
11018 *
11019 * where alpha and beta are scalars, A is a symmetric matrix and B and
11020 * C are m by n matrices.
11021 *
11022 * Parameters
11023 * ==========
11024 *
11025 * SIDE - CHARACTER*1.
11026 * On entry, SIDE specifies whether the symmetric matrix A
11027 * appears on the left or right in the operation as follows:
11028 *
11029 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
11030 *
11031 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
11032 *
11033 * Unchanged on exit.
11034 *
11035 * UPLO - CHARACTER*1.
11036 * On entry, UPLO specifies whether the upper or lower
11037 * triangular part of the symmetric matrix A is to be
11038 * referenced as follows:
11039 *
11040 * UPLO = 'U' or 'u' Only the upper triangular part of the
11041 * symmetric matrix is to be referenced.
11042 *
11043 * UPLO = 'L' or 'l' Only the lower triangular part of the
11044 * symmetric matrix is to be referenced.
11045 *
11046 * Unchanged on exit.
11047 *
11048 * M - INTEGER.
11049 * On entry, M specifies the number of rows of the matrix C.
11050 * M must be at least zero.
11051 * Unchanged on exit.
11052 *
11053 * N - INTEGER.
11054 * On entry, N specifies the number of columns of the matrix C.
11055 * N must be at least zero.
11056 * Unchanged on exit.
11057 *
11058 * ALPHA - DOUBLE PRECISION.
11059 * On entry, ALPHA specifies the scalar alpha.
11060 * Unchanged on exit.
11061 *
11062 * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
11063 * m when SIDE = 'L' or 'l' and is n otherwise.
11064 * Before entry with SIDE = 'L' or 'l', the m by m part of
11065 * the array A must contain the symmetric matrix, such that
11066 * when UPLO = 'U' or 'u', the leading m by m upper triangular
11067 * part of the array A must contain the upper triangular part
11068 * of the symmetric matrix and the strictly lower triangular
11069 * part of A is not referenced, and when UPLO = 'L' or 'l',
11070 * the leading m by m lower triangular part of the array A
11071 * must contain the lower triangular part of the symmetric
11072 * matrix and the strictly upper triangular part of A is not
11073 * referenced.
11074 * Before entry with SIDE = 'R' or 'r', the n by n part of
11075 * the array A must contain the symmetric matrix, such that
11076 * when UPLO = 'U' or 'u', the leading n by n upper triangular
11077 * part of the array A must contain the upper triangular part
11078 * of the symmetric matrix and the strictly lower triangular
11079 * part of A is not referenced, and when UPLO = 'L' or 'l',
11080 * the leading n by n lower triangular part of the array A
11081 * must contain the lower triangular part of the symmetric
11082 * matrix and the strictly upper triangular part of A is not
11083 * referenced.
11084 * Unchanged on exit.
11085 *
11086 * LDA - INTEGER.
11087 * On entry, LDA specifies the first dimension of A as declared
11088 * in the calling (sub) program. When SIDE = 'L' or 'l' then
11089 * LDA must be at least max( 1, m ), otherwise LDA must be at
11090 * least max( 1, n ).
11091 * Unchanged on exit.
11092 *
11093 * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
11094 * Before entry, the leading m by n part of the array B must
11095 * contain the matrix B.
11096 * Unchanged on exit.
11097 *
11098 * LDB - INTEGER.
11099 * On entry, LDB specifies the first dimension of B as declared
11100 * in the calling (sub) program. LDB must be at least
11101 * max( 1, m ).
11102 * Unchanged on exit.
11103 *
11104 * BETA - DOUBLE PRECISION.
11105 * On entry, BETA specifies the scalar beta. When BETA is
11106 * supplied as zero then C need not be set on input.
11107 * Unchanged on exit.
11108 *
11109 * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
11110 * Before entry, the leading m by n part of the array C must
11111 * contain the matrix C, except when beta is zero, in which
11112 * case C need not be set on entry.
11113 * On exit, the array C is overwritten by the m by n updated
11114 * matrix.
11115 *
11116 * LDC - INTEGER.
11117 * On entry, LDC specifies the first dimension of C as declared
11118 * in the calling (sub) program. LDC must be at least
11119 * max( 1, m ).
11120 * Unchanged on exit.
11121 *
11122 *
11123 * Level 3 Blas routine.
11124 *
11125 * -- Written on 8-February-1989.
11126 * Jack Dongarra, Argonne National Laboratory.
11127 * Iain Duff, AERE Harwell.
11128 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
11129 * Sven Hammarling, Numerical Algorithms Group Ltd.
11130 *
11131 *
11132 * .. External Functions ..
11133  LOGICAL LSAME
11134  EXTERNAL lsame
11135 * .. External Subroutines ..
11136  EXTERNAL xerbla
11137 * .. Intrinsic Functions ..
11138  INTRINSIC max
11139 * .. Local Scalars ..
11140  LOGICAL UPPER
11141  INTEGER I, INFO, J, K, NROWA
11142  DOUBLE PRECISION TEMP1, TEMP2
11143 * .. Parameters ..
11144  DOUBLE PRECISION ONE , ZERO
11145  parameter( one = 1.0d+0, zero = 0.0d+0 )
11146 * ..
11147 * .. Executable Statements ..
11148 *
11149 * Set NROWA as the number of rows of A.
11150 *
11151  IF( lsame( side, 'L' ) )THEN
11152  nrowa = m
11153  ELSE
11154  nrowa = n
11155  END IF
11156  upper = lsame( uplo, 'U' )
11157 *
11158 * Test the input parameters.
11159 *
11160  info = 0
11161  IF( ( .NOT.lsame( side, 'L' ) ).AND.
11162  $ ( .NOT.lsame( side, 'R' ) ) )THEN
11163  info = 1
11164  ELSE IF( ( .NOT.upper ).AND.
11165  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
11166  info = 2
11167  ELSE IF( m .LT.0 )THEN
11168  info = 3
11169  ELSE IF( n .LT.0 )THEN
11170  info = 4
11171  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
11172  info = 7
11173  ELSE IF( ldb.LT.max( 1, m ) )THEN
11174  info = 9
11175  ELSE IF( ldc.LT.max( 1, m ) )THEN
11176  info = 12
11177  END IF
11178  IF( info.NE.0 )THEN
11179  CALL xerbla( 'DSYMM ', info )
11180  RETURN
11181  END IF
11182 *
11183 * Quick return if possible.
11184 *
11185  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
11186  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
11187  $ RETURN
11188 *
11189 * And when alpha.eq.zero.
11190 *
11191  IF( alpha.EQ.zero )THEN
11192  IF( beta.EQ.zero )THEN
11193  DO 20, j = 1, n
11194  DO 10, i = 1, m
11195  c( i, j ) = zero
11196  10 CONTINUE
11197  20 CONTINUE
11198  ELSE
11199  DO 40, j = 1, n
11200  DO 30, i = 1, m
11201  c( i, j ) = beta*c( i, j )
11202  30 CONTINUE
11203  40 CONTINUE
11204  END IF
11205  RETURN
11206  END IF
11207 *
11208 * Start the operations.
11209 *
11210  IF( lsame( side, 'L' ) )THEN
11211 *
11212 * Form C := alpha*A*B + beta*C.
11213 *
11214  IF( upper )THEN
11215  DO 70, j = 1, n
11216  DO 60, i = 1, m
11217  temp1 = alpha*b( i, j )
11218  temp2 = zero
11219  DO 50, k = 1, i - 1
11220  c( k, j ) = c( k, j ) + temp1 *a( k, i )
11221  temp2 = temp2 + b( k, j )*a( k, i )
11222  50 CONTINUE
11223  IF( beta.EQ.zero )THEN
11224  c( i, j ) = temp1*a( i, i ) + alpha*temp2
11225  ELSE
11226  c( i, j ) = beta *c( i, j ) +
11227  $ temp1*a( i, i ) + alpha*temp2
11228  END IF
11229  60 CONTINUE
11230  70 CONTINUE
11231  ELSE
11232  DO 100, j = 1, n
11233  DO 90, i = m, 1, -1
11234  temp1 = alpha*b( i, j )
11235  temp2 = zero
11236  DO 80, k = i + 1, m
11237  c( k, j ) = c( k, j ) + temp1 *a( k, i )
11238  temp2 = temp2 + b( k, j )*a( k, i )
11239  80 CONTINUE
11240  IF( beta.EQ.zero )THEN
11241  c( i, j ) = temp1*a( i, i ) + alpha*temp2
11242  ELSE
11243  c( i, j ) = beta *c( i, j ) +
11244  $ temp1*a( i, i ) + alpha*temp2
11245  END IF
11246  90 CONTINUE
11247  100 CONTINUE
11248  END IF
11249  ELSE
11250 *
11251 * Form C := alpha*B*A + beta*C.
11252 *
11253  DO 170, j = 1, n
11254  temp1 = alpha*a( j, j )
11255  IF( beta.EQ.zero )THEN
11256  DO 110, i = 1, m
11257  c( i, j ) = temp1*b( i, j )
11258  110 CONTINUE
11259  ELSE
11260  DO 120, i = 1, m
11261  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
11262  120 CONTINUE
11263  END IF
11264  DO 140, k = 1, j - 1
11265  IF( upper )THEN
11266  temp1 = alpha*a( k, j )
11267  ELSE
11268  temp1 = alpha*a( j, k )
11269  END IF
11270  DO 130, i = 1, m
11271  c( i, j ) = c( i, j ) + temp1*b( i, k )
11272  130 CONTINUE
11273  140 CONTINUE
11274  DO 160, k = j + 1, n
11275  IF( upper )THEN
11276  temp1 = alpha*a( j, k )
11277  ELSE
11278  temp1 = alpha*a( k, j )
11279  END IF
11280  DO 150, i = 1, m
11281  c( i, j ) = c( i, j ) + temp1*b( i, k )
11282  150 CONTINUE
11283  160 CONTINUE
11284  170 CONTINUE
11285  END IF
11286 *
11287  RETURN
11288 *
11289 * End of DSYMM .
11290 *
11291  END
11292  SUBROUTINE dsymv ( UPLO, N, ALPHA, A, LDA, X, INCX,
11293  $ beta, y, incy )
11294 * .. Scalar Arguments ..
11295  DOUBLE PRECISION ALPHA, BETA
11296  INTEGER INCX, INCY, LDA, N
11297  CHARACTER*1 UPLO
11298 * .. Array Arguments ..
11299  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
11300 * ..
11301 *
11302 * Purpose
11303 * =======
11304 *
11305 * DSYMV performs the matrix-vector operation
11306 *
11307 * y := alpha*A*x + beta*y,
11308 *
11309 * where alpha and beta are scalars, x and y are n element vectors and
11310 * A is an n by n symmetric matrix.
11311 *
11312 * Parameters
11313 * ==========
11314 *
11315 * UPLO - CHARACTER*1.
11316 * On entry, UPLO specifies whether the upper or lower
11317 * triangular part of the array A is to be referenced as
11318 * follows:
11319 *
11320 * UPLO = 'U' or 'u' Only the upper triangular part of A
11321 * is to be referenced.
11322 *
11323 * UPLO = 'L' or 'l' Only the lower triangular part of A
11324 * is to be referenced.
11325 *
11326 * Unchanged on exit.
11327 *
11328 * N - INTEGER.
11329 * On entry, N specifies the order of the matrix A.
11330 * N must be at least zero.
11331 * Unchanged on exit.
11332 *
11333 * ALPHA - DOUBLE PRECISION.
11334 * On entry, ALPHA specifies the scalar alpha.
11335 * Unchanged on exit.
11336 *
11337 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
11338 * Before entry with UPLO = 'U' or 'u', the leading n by n
11339 * upper triangular part of the array A must contain the upper
11340 * triangular part of the symmetric matrix and the strictly
11341 * lower triangular part of A is not referenced.
11342 * Before entry with UPLO = 'L' or 'l', the leading n by n
11343 * lower triangular part of the array A must contain the lower
11344 * triangular part of the symmetric matrix and the strictly
11345 * upper triangular part of A is not referenced.
11346 * Unchanged on exit.
11347 *
11348 * LDA - INTEGER.
11349 * On entry, LDA specifies the first dimension of A as declared
11350 * in the calling (sub) program. LDA must be at least
11351 * max( 1, n ).
11352 * Unchanged on exit.
11353 *
11354 * X - DOUBLE PRECISION array of dimension at least
11355 * ( 1 + ( n - 1 )*abs( INCX ) ).
11356 * Before entry, the incremented array X must contain the n
11357 * element vector x.
11358 * Unchanged on exit.
11359 *
11360 * INCX - INTEGER.
11361 * On entry, INCX specifies the increment for the elements of
11362 * X. INCX must not be zero.
11363 * Unchanged on exit.
11364 *
11365 * BETA - DOUBLE PRECISION.
11366 * On entry, BETA specifies the scalar beta. When BETA is
11367 * supplied as zero then Y need not be set on input.
11368 * Unchanged on exit.
11369 *
11370 * Y - DOUBLE PRECISION array of dimension at least
11371 * ( 1 + ( n - 1 )*abs( INCY ) ).
11372 * Before entry, the incremented array Y must contain the n
11373 * element vector y. On exit, Y is overwritten by the updated
11374 * vector y.
11375 *
11376 * INCY - INTEGER.
11377 * On entry, INCY specifies the increment for the elements of
11378 * Y. INCY must not be zero.
11379 * Unchanged on exit.
11380 *
11381 *
11382 * Level 2 Blas routine.
11383 *
11384 * -- Written on 22-October-1986.
11385 * Jack Dongarra, Argonne National Lab.
11386 * Jeremy Du Croz, Nag Central Office.
11387 * Sven Hammarling, Nag Central Office.
11388 * Richard Hanson, Sandia National Labs.
11389 *
11390 *
11391 * .. Parameters ..
11392  DOUBLE PRECISION ONE , ZERO
11393  parameter( one = 1.0d+0, zero = 0.0d+0 )
11394 * .. Local Scalars ..
11395  DOUBLE PRECISION TEMP1, TEMP2
11396  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
11397 * .. External Functions ..
11398  LOGICAL LSAME
11399  EXTERNAL lsame
11400 * .. External Subroutines ..
11401  EXTERNAL xerbla
11402 * .. Intrinsic Functions ..
11403  INTRINSIC max
11404 * ..
11405 * .. Executable Statements ..
11406 *
11407 * Test the input parameters.
11408 *
11409  info = 0
11410  IF ( .NOT.lsame( uplo, 'U' ).AND.
11411  $ .NOT.lsame( uplo, 'L' ) )THEN
11412  info = 1
11413  ELSE IF( n.LT.0 )THEN
11414  info = 2
11415  ELSE IF( lda.LT.max( 1, n ) )THEN
11416  info = 5
11417  ELSE IF( incx.EQ.0 )THEN
11418  info = 7
11419  ELSE IF( incy.EQ.0 )THEN
11420  info = 10
11421  END IF
11422  IF( info.NE.0 )THEN
11423  CALL xerbla( 'DSYMV ', info )
11424  RETURN
11425  END IF
11426 *
11427 * Quick return if possible.
11428 *
11429  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
11430  $ RETURN
11431 *
11432 * Set up the start points in X and Y.
11433 *
11434  IF( incx.GT.0 )THEN
11435  kx = 1
11436  ELSE
11437  kx = 1 - ( n - 1 )*incx
11438  END IF
11439  IF( incy.GT.0 )THEN
11440  ky = 1
11441  ELSE
11442  ky = 1 - ( n - 1 )*incy
11443  END IF
11444 *
11445 * Start the operations. In this version the elements of A are
11446 * accessed sequentially with one pass through the triangular part
11447 * of A.
11448 *
11449 * First form y := beta*y.
11450 *
11451  IF( beta.NE.one )THEN
11452  IF( incy.EQ.1 )THEN
11453  IF( beta.EQ.zero )THEN
11454  DO 10, i = 1, n
11455  y( i ) = zero
11456  10 CONTINUE
11457  ELSE
11458  DO 20, i = 1, n
11459  y( i ) = beta*y( i )
11460  20 CONTINUE
11461  END IF
11462  ELSE
11463  iy = ky
11464  IF( beta.EQ.zero )THEN
11465  DO 30, i = 1, n
11466  y( iy ) = zero
11467  iy = iy + incy
11468  30 CONTINUE
11469  ELSE
11470  DO 40, i = 1, n
11471  y( iy ) = beta*y( iy )
11472  iy = iy + incy
11473  40 CONTINUE
11474  END IF
11475  END IF
11476  END IF
11477  IF( alpha.EQ.zero )
11478  $ RETURN
11479  IF( lsame( uplo, 'U' ) )THEN
11480 *
11481 * Form y when A is stored in upper triangle.
11482 *
11483  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
11484  DO 60, j = 1, n
11485  temp1 = alpha*x( j )
11486  temp2 = zero
11487  DO 50, i = 1, j - 1
11488  y( i ) = y( i ) + temp1*a( i, j )
11489  temp2 = temp2 + a( i, j )*x( i )
11490  50 CONTINUE
11491  y( j ) = y( j ) + temp1*a( j, j ) + alpha*temp2
11492  60 CONTINUE
11493  ELSE
11494  jx = kx
11495  jy = ky
11496  DO 80, j = 1, n
11497  temp1 = alpha*x( jx )
11498  temp2 = zero
11499  ix = kx
11500  iy = ky
11501  DO 70, i = 1, j - 1
11502  y( iy ) = y( iy ) + temp1*a( i, j )
11503  temp2 = temp2 + a( i, j )*x( ix )
11504  ix = ix + incx
11505  iy = iy + incy
11506  70 CONTINUE
11507  y( jy ) = y( jy ) + temp1*a( j, j ) + alpha*temp2
11508  jx = jx + incx
11509  jy = jy + incy
11510  80 CONTINUE
11511  END IF
11512  ELSE
11513 *
11514 * Form y when A is stored in lower triangle.
11515 *
11516  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
11517  DO 100, j = 1, n
11518  temp1 = alpha*x( j )
11519  temp2 = zero
11520  y( j ) = y( j ) + temp1*a( j, j )
11521  DO 90, i = j + 1, n
11522  y( i ) = y( i ) + temp1*a( i, j )
11523  temp2 = temp2 + a( i, j )*x( i )
11524  90 CONTINUE
11525  y( j ) = y( j ) + alpha*temp2
11526  100 CONTINUE
11527  ELSE
11528  jx = kx
11529  jy = ky
11530  DO 120, j = 1, n
11531  temp1 = alpha*x( jx )
11532  temp2 = zero
11533  y( jy ) = y( jy ) + temp1*a( j, j )
11534  ix = jx
11535  iy = jy
11536  DO 110, i = j + 1, n
11537  ix = ix + incx
11538  iy = iy + incy
11539  y( iy ) = y( iy ) + temp1*a( i, j )
11540  temp2 = temp2 + a( i, j )*x( ix )
11541  110 CONTINUE
11542  y( jy ) = y( jy ) + alpha*temp2
11543  jx = jx + incx
11544  jy = jy + incy
11545  120 CONTINUE
11546  END IF
11547  END IF
11548 *
11549  RETURN
11550 *
11551 * End of DSYMV .
11552 *
11553  END
11554  SUBROUTINE dsyr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
11555 * .. Scalar Arguments ..
11556  DOUBLE PRECISION ALPHA
11557  INTEGER INCX, INCY, LDA, N
11558  CHARACTER*1 UPLO
11559 * .. Array Arguments ..
11560  DOUBLE PRECISION A( lda, * ), X( * ), Y( * )
11561 * ..
11562 *
11563 * Purpose
11564 * =======
11565 *
11566 * DSYR2 performs the symmetric rank 2 operation
11567 *
11568 * A := alpha*x*y' + alpha*y*x' + A,
11569 *
11570 * where alpha is a scalar, x and y are n element vectors and A is an n
11571 * by n symmetric matrix.
11572 *
11573 * Parameters
11574 * ==========
11575 *
11576 * UPLO - CHARACTER*1.
11577 * On entry, UPLO specifies whether the upper or lower
11578 * triangular part of the array A is to be referenced as
11579 * follows:
11580 *
11581 * UPLO = 'U' or 'u' Only the upper triangular part of A
11582 * is to be referenced.
11583 *
11584 * UPLO = 'L' or 'l' Only the lower triangular part of A
11585 * is to be referenced.
11586 *
11587 * Unchanged on exit.
11588 *
11589 * N - INTEGER.
11590 * On entry, N specifies the order of the matrix A.
11591 * N must be at least zero.
11592 * Unchanged on exit.
11593 *
11594 * ALPHA - DOUBLE PRECISION.
11595 * On entry, ALPHA specifies the scalar alpha.
11596 * Unchanged on exit.
11597 *
11598 * X - DOUBLE PRECISION array of dimension at least
11599 * ( 1 + ( n - 1 )*abs( INCX ) ).
11600 * Before entry, the incremented array X must contain the n
11601 * element vector x.
11602 * Unchanged on exit.
11603 *
11604 * INCX - INTEGER.
11605 * On entry, INCX specifies the increment for the elements of
11606 * X. INCX must not be zero.
11607 * Unchanged on exit.
11608 *
11609 * Y - DOUBLE PRECISION array of dimension at least
11610 * ( 1 + ( n - 1 )*abs( INCY ) ).
11611 * Before entry, the incremented array Y must contain the n
11612 * element vector y.
11613 * Unchanged on exit.
11614 *
11615 * INCY - INTEGER.
11616 * On entry, INCY specifies the increment for the elements of
11617 * Y. INCY must not be zero.
11618 * Unchanged on exit.
11619 *
11620 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
11621 * Before entry with UPLO = 'U' or 'u', the leading n by n
11622 * upper triangular part of the array A must contain the upper
11623 * triangular part of the symmetric matrix and the strictly
11624 * lower triangular part of A is not referenced. On exit, the
11625 * upper triangular part of the array A is overwritten by the
11626 * upper triangular part of the updated matrix.
11627 * Before entry with UPLO = 'L' or 'l', the leading n by n
11628 * lower triangular part of the array A must contain the lower
11629 * triangular part of the symmetric matrix and the strictly
11630 * upper triangular part of A is not referenced. On exit, the
11631 * lower triangular part of the array A is overwritten by the
11632 * lower triangular part of the updated matrix.
11633 *
11634 * LDA - INTEGER.
11635 * On entry, LDA specifies the first dimension of A as declared
11636 * in the calling (sub) program. LDA must be at least
11637 * max( 1, n ).
11638 * Unchanged on exit.
11639 *
11640 *
11641 * Level 2 Blas routine.
11642 *
11643 * -- Written on 22-October-1986.
11644 * Jack Dongarra, Argonne National Lab.
11645 * Jeremy Du Croz, Nag Central Office.
11646 * Sven Hammarling, Nag Central Office.
11647 * Richard Hanson, Sandia National Labs.
11648 *
11649 *
11650 * .. Parameters ..
11651  DOUBLE PRECISION ZERO
11652  parameter( zero = 0.0d+0 )
11653 * .. Local Scalars ..
11654  DOUBLE PRECISION TEMP1, TEMP2
11655  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
11656 * .. External Functions ..
11657  LOGICAL LSAME
11658  EXTERNAL lsame
11659 * .. External Subroutines ..
11660  EXTERNAL xerbla
11661 * .. Intrinsic Functions ..
11662  INTRINSIC max
11663 * ..
11664 * .. Executable Statements ..
11665 *
11666 * Test the input parameters.
11667 *
11668  info = 0
11669  IF ( .NOT.lsame( uplo, 'U' ).AND.
11670  $ .NOT.lsame( uplo, 'L' ) )THEN
11671  info = 1
11672  ELSE IF( n.LT.0 )THEN
11673  info = 2
11674  ELSE IF( incx.EQ.0 )THEN
11675  info = 5
11676  ELSE IF( incy.EQ.0 )THEN
11677  info = 7
11678  ELSE IF( lda.LT.max( 1, n ) )THEN
11679  info = 9
11680  END IF
11681  IF( info.NE.0 )THEN
11682  CALL xerbla( 'DSYR2 ', info )
11683  RETURN
11684  END IF
11685 *
11686 * Quick return if possible.
11687 *
11688  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
11689  $ RETURN
11690 *
11691 * Set up the start points in X and Y if the increments are not both
11692 * unity.
11693 *
11694  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
11695  IF( incx.GT.0 )THEN
11696  kx = 1
11697  ELSE
11698  kx = 1 - ( n - 1 )*incx
11699  END IF
11700  IF( incy.GT.0 )THEN
11701  ky = 1
11702  ELSE
11703  ky = 1 - ( n - 1 )*incy
11704  END IF
11705  jx = kx
11706  jy = ky
11707  END IF
11708 *
11709 * Start the operations. In this version the elements of A are
11710 * accessed sequentially with one pass through the triangular part
11711 * of A.
11712 *
11713  IF( lsame( uplo, 'U' ) )THEN
11714 *
11715 * Form A when A is stored in the upper triangle.
11716 *
11717  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
11718  DO 20, j = 1, n
11719  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
11720  temp1 = alpha*y( j )
11721  temp2 = alpha*x( j )
11722  DO 10, i = 1, j
11723  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
11724  10 CONTINUE
11725  END IF
11726  20 CONTINUE
11727  ELSE
11728  DO 40, j = 1, n
11729  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
11730  temp1 = alpha*y( jy )
11731  temp2 = alpha*x( jx )
11732  ix = kx
11733  iy = ky
11734  DO 30, i = 1, j
11735  a( i, j ) = a( i, j ) + x( ix )*temp1
11736  $ + y( iy )*temp2
11737  ix = ix + incx
11738  iy = iy + incy
11739  30 CONTINUE
11740  END IF
11741  jx = jx + incx
11742  jy = jy + incy
11743  40 CONTINUE
11744  END IF
11745  ELSE
11746 *
11747 * Form A when A is stored in the lower triangle.
11748 *
11749  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
11750  DO 60, j = 1, n
11751  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
11752  temp1 = alpha*y( j )
11753  temp2 = alpha*x( j )
11754  DO 50, i = j, n
11755  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
11756  50 CONTINUE
11757  END IF
11758  60 CONTINUE
11759  ELSE
11760  DO 80, j = 1, n
11761  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
11762  temp1 = alpha*y( jy )
11763  temp2 = alpha*x( jx )
11764  ix = jx
11765  iy = jy
11766  DO 70, i = j, n
11767  a( i, j ) = a( i, j ) + x( ix )*temp1
11768  $ + y( iy )*temp2
11769  ix = ix + incx
11770  iy = iy + incy
11771  70 CONTINUE
11772  END IF
11773  jx = jx + incx
11774  jy = jy + incy
11775  80 CONTINUE
11776  END IF
11777  END IF
11778 *
11779  RETURN
11780 *
11781 * End of DSYR2 .
11782 *
11783  END
11784  SUBROUTINE dsyr2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
11785  $ beta, c, ldc )
11786 * .. Scalar Arguments ..
11787  CHARACTER*1 UPLO, TRANS
11788  INTEGER N, K, LDA, LDB, LDC
11789  DOUBLE PRECISION ALPHA, BETA
11790 * .. Array Arguments ..
11791  DOUBLE PRECISION A( lda, * ), B( ldb, * ), C( ldc, * )
11792 * ..
11793 *
11794 * Purpose
11795 * =======
11796 *
11797 * DSYR2K performs one of the symmetric rank 2k operations
11798 *
11799 * C := alpha*A*B' + alpha*B*A' + beta*C,
11800 *
11801 * or
11802 *
11803 * C := alpha*A'*B + alpha*B'*A + beta*C,
11804 *
11805 * where alpha and beta are scalars, C is an n by n symmetric matrix
11806 * and A and B are n by k matrices in the first case and k by n
11807 * matrices in the second case.
11808 *
11809 * Parameters
11810 * ==========
11811 *
11812 * UPLO - CHARACTER*1.
11813 * On entry, UPLO specifies whether the upper or lower
11814 * triangular part of the array C is to be referenced as
11815 * follows:
11816 *
11817 * UPLO = 'U' or 'u' Only the upper triangular part of C
11818 * is to be referenced.
11819 *
11820 * UPLO = 'L' or 'l' Only the lower triangular part of C
11821 * is to be referenced.
11822 *
11823 * Unchanged on exit.
11824 *
11825 * TRANS - CHARACTER*1.
11826 * On entry, TRANS specifies the operation to be performed as
11827 * follows:
11828 *
11829 * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
11830 * beta*C.
11831 *
11832 * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
11833 * beta*C.
11834 *
11835 * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
11836 * beta*C.
11837 *
11838 * Unchanged on exit.
11839 *
11840 * N - INTEGER.
11841 * On entry, N specifies the order of the matrix C. N must be
11842 * at least zero.
11843 * Unchanged on exit.
11844 *
11845 * K - INTEGER.
11846 * On entry with TRANS = 'N' or 'n', K specifies the number
11847 * of columns of the matrices A and B, and on entry with
11848 * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
11849 * of rows of the matrices A and B. K must be at least zero.
11850 * Unchanged on exit.
11851 *
11852 * ALPHA - DOUBLE PRECISION.
11853 * On entry, ALPHA specifies the scalar alpha.
11854 * Unchanged on exit.
11855 *
11856 * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
11857 * k when TRANS = 'N' or 'n', and is n otherwise.
11858 * Before entry with TRANS = 'N' or 'n', the leading n by k
11859 * part of the array A must contain the matrix A, otherwise
11860 * the leading k by n part of the array A must contain the
11861 * matrix A.
11862 * Unchanged on exit.
11863 *
11864 * LDA - INTEGER.
11865 * On entry, LDA specifies the first dimension of A as declared
11866 * in the calling (sub) program. When TRANS = 'N' or 'n'
11867 * then LDA must be at least max( 1, n ), otherwise LDA must
11868 * be at least max( 1, k ).
11869 * Unchanged on exit.
11870 *
11871 * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
11872 * k when TRANS = 'N' or 'n', and is n otherwise.
11873 * Before entry with TRANS = 'N' or 'n', the leading n by k
11874 * part of the array B must contain the matrix B, otherwise
11875 * the leading k by n part of the array B must contain the
11876 * matrix B.
11877 * Unchanged on exit.
11878 *
11879 * LDB - INTEGER.
11880 * On entry, LDB specifies the first dimension of B as declared
11881 * in the calling (sub) program. When TRANS = 'N' or 'n'
11882 * then LDB must be at least max( 1, n ), otherwise LDB must
11883 * be at least max( 1, k ).
11884 * Unchanged on exit.
11885 *
11886 * BETA - DOUBLE PRECISION.
11887 * On entry, BETA specifies the scalar beta.
11888 * Unchanged on exit.
11889 *
11890 * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
11891 * Before entry with UPLO = 'U' or 'u', the leading n by n
11892 * upper triangular part of the array C must contain the upper
11893 * triangular part of the symmetric matrix and the strictly
11894 * lower triangular part of C is not referenced. On exit, the
11895 * upper triangular part of the array C is overwritten by the
11896 * upper triangular part of the updated matrix.
11897 * Before entry with UPLO = 'L' or 'l', the leading n by n
11898 * lower triangular part of the array C must contain the lower
11899 * triangular part of the symmetric matrix and the strictly
11900 * upper triangular part of C is not referenced. On exit, the
11901 * lower triangular part of the array C is overwritten by the
11902 * lower triangular part of the updated matrix.
11903 *
11904 * LDC - INTEGER.
11905 * On entry, LDC specifies the first dimension of C as declared
11906 * in the calling (sub) program. LDC must be at least
11907 * max( 1, n ).
11908 * Unchanged on exit.
11909 *
11910 *
11911 * Level 3 Blas routine.
11912 *
11913 *
11914 * -- Written on 8-February-1989.
11915 * Jack Dongarra, Argonne National Laboratory.
11916 * Iain Duff, AERE Harwell.
11917 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
11918 * Sven Hammarling, Numerical Algorithms Group Ltd.
11919 *
11920 *
11921 * .. External Functions ..
11922  LOGICAL LSAME
11923  EXTERNAL lsame
11924 * .. External Subroutines ..
11925  EXTERNAL xerbla
11926 * .. Intrinsic Functions ..
11927  INTRINSIC max
11928 * .. Local Scalars ..
11929  LOGICAL UPPER
11930  INTEGER I, INFO, J, L, NROWA
11931  DOUBLE PRECISION TEMP1, TEMP2
11932 * .. Parameters ..
11933  DOUBLE PRECISION ONE , ZERO
11934  parameter( one = 1.0d+0, zero = 0.0d+0 )
11935 * ..
11936 * .. Executable Statements ..
11937 *
11938 * Test the input parameters.
11939 *
11940  IF( lsame( trans, 'N' ) )THEN
11941  nrowa = n
11942  ELSE
11943  nrowa = k
11944  END IF
11945  upper = lsame( uplo, 'U' )
11946 *
11947  info = 0
11948  IF( ( .NOT.upper ).AND.
11949  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
11950  info = 1
11951  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
11952  $ ( .NOT.lsame( trans, 'T' ) ).AND.
11953  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
11954  info = 2
11955  ELSE IF( n .LT.0 )THEN
11956  info = 3
11957  ELSE IF( k .LT.0 )THEN
11958  info = 4
11959  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
11960  info = 7
11961  ELSE IF( ldb.LT.max( 1, nrowa ) )THEN
11962  info = 9
11963  ELSE IF( ldc.LT.max( 1, n ) )THEN
11964  info = 12
11965  END IF
11966  IF( info.NE.0 )THEN
11967  CALL xerbla( 'DSYR2K', info )
11968  RETURN
11969  END IF
11970 *
11971 * Quick return if possible.
11972 *
11973  IF( ( n.EQ.0 ).OR.
11974  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
11975  $ RETURN
11976 *
11977 * And when alpha.eq.zero.
11978 *
11979  IF( alpha.EQ.zero )THEN
11980  IF( upper )THEN
11981  IF( beta.EQ.zero )THEN
11982  DO 20, j = 1, n
11983  DO 10, i = 1, j
11984  c( i, j ) = zero
11985  10 CONTINUE
11986  20 CONTINUE
11987  ELSE
11988  DO 40, j = 1, n
11989  DO 30, i = 1, j
11990  c( i, j ) = beta*c( i, j )
11991  30 CONTINUE
11992  40 CONTINUE
11993  END IF
11994  ELSE
11995  IF( beta.EQ.zero )THEN
11996  DO 60, j = 1, n
11997  DO 50, i = j, n
11998  c( i, j ) = zero
11999  50 CONTINUE
12000  60 CONTINUE
12001  ELSE
12002  DO 80, j = 1, n
12003  DO 70, i = j, n
12004  c( i, j ) = beta*c( i, j )
12005  70 CONTINUE
12006  80 CONTINUE
12007  END IF
12008  END IF
12009  RETURN
12010  END IF
12011 *
12012 * Start the operations.
12013 *
12014  IF( lsame( trans, 'N' ) )THEN
12015 *
12016 * Form C := alpha*A*B' + alpha*B*A' + C.
12017 *
12018  IF( upper )THEN
12019  DO 130, j = 1, n
12020  IF( beta.EQ.zero )THEN
12021  DO 90, i = 1, j
12022  c( i, j ) = zero
12023  90 CONTINUE
12024  ELSE IF( beta.NE.one )THEN
12025  DO 100, i = 1, j
12026  c( i, j ) = beta*c( i, j )
12027  100 CONTINUE
12028  END IF
12029  DO 120, l = 1, k
12030  IF( ( a( j, l ).NE.zero ).OR.
12031  $ ( b( j, l ).NE.zero ) )THEN
12032  temp1 = alpha*b( j, l )
12033  temp2 = alpha*a( j, l )
12034  DO 110, i = 1, j
12035  c( i, j ) = c( i, j ) +
12036  $ a( i, l )*temp1 + b( i, l )*temp2
12037  110 CONTINUE
12038  END IF
12039  120 CONTINUE
12040  130 CONTINUE
12041  ELSE
12042  DO 180, j = 1, n
12043  IF( beta.EQ.zero )THEN
12044  DO 140, i = j, n
12045  c( i, j ) = zero
12046  140 CONTINUE
12047  ELSE IF( beta.NE.one )THEN
12048  DO 150, i = j, n
12049  c( i, j ) = beta*c( i, j )
12050  150 CONTINUE
12051  END IF
12052  DO 170, l = 1, k
12053  IF( ( a( j, l ).NE.zero ).OR.
12054  $ ( b( j, l ).NE.zero ) )THEN
12055  temp1 = alpha*b( j, l )
12056  temp2 = alpha*a( j, l )
12057  DO 160, i = j, n
12058  c( i, j ) = c( i, j ) +
12059  $ a( i, l )*temp1 + b( i, l )*temp2
12060  160 CONTINUE
12061  END IF
12062  170 CONTINUE
12063  180 CONTINUE
12064  END IF
12065  ELSE
12066 *
12067 * Form C := alpha*A'*B + alpha*B'*A + C.
12068 *
12069  IF( upper )THEN
12070  DO 210, j = 1, n
12071  DO 200, i = 1, j
12072  temp1 = zero
12073  temp2 = zero
12074  DO 190, l = 1, k
12075  temp1 = temp1 + a( l, i )*b( l, j )
12076  temp2 = temp2 + b( l, i )*a( l, j )
12077  190 CONTINUE
12078  IF( beta.EQ.zero )THEN
12079  c( i, j ) = alpha*temp1 + alpha*temp2
12080  ELSE
12081  c( i, j ) = beta *c( i, j ) +
12082  $ alpha*temp1 + alpha*temp2
12083  END IF
12084  200 CONTINUE
12085  210 CONTINUE
12086  ELSE
12087  DO 240, j = 1, n
12088  DO 230, i = j, n
12089  temp1 = zero
12090  temp2 = zero
12091  DO 220, l = 1, k
12092  temp1 = temp1 + a( l, i )*b( l, j )
12093  temp2 = temp2 + b( l, i )*a( l, j )
12094  220 CONTINUE
12095  IF( beta.EQ.zero )THEN
12096  c( i, j ) = alpha*temp1 + alpha*temp2
12097  ELSE
12098  c( i, j ) = beta *c( i, j ) +
12099  $ alpha*temp1 + alpha*temp2
12100  END IF
12101  230 CONTINUE
12102  240 CONTINUE
12103  END IF
12104  END IF
12105 *
12106  RETURN
12107 *
12108 * End of DSYR2K.
12109 *
12110  END
12111  SUBROUTINE dsyr ( UPLO, N, ALPHA, X, INCX, A, LDA )
12112 * .. Scalar Arguments ..
12113  DOUBLE PRECISION ALPHA
12114  INTEGER INCX, LDA, N
12115  CHARACTER*1 UPLO
12116 * .. Array Arguments ..
12117  DOUBLE PRECISION A( lda, * ), X( * )
12118 * ..
12119 *
12120 * Purpose
12121 * =======
12122 *
12123 * DSYR performs the symmetric rank 1 operation
12124 *
12125 * A := alpha*x*x' + A,
12126 *
12127 * where alpha is a real scalar, x is an n element vector and A is an
12128 * n by n symmetric matrix.
12129 *
12130 * Parameters
12131 * ==========
12132 *
12133 * UPLO - CHARACTER*1.
12134 * On entry, UPLO specifies whether the upper or lower
12135 * triangular part of the array A is to be referenced as
12136 * follows:
12137 *
12138 * UPLO = 'U' or 'u' Only the upper triangular part of A
12139 * is to be referenced.
12140 *
12141 * UPLO = 'L' or 'l' Only the lower triangular part of A
12142 * is to be referenced.
12143 *
12144 * Unchanged on exit.
12145 *
12146 * N - INTEGER.
12147 * On entry, N specifies the order of the matrix A.
12148 * N must be at least zero.
12149 * Unchanged on exit.
12150 *
12151 * ALPHA - DOUBLE PRECISION.
12152 * On entry, ALPHA specifies the scalar alpha.
12153 * Unchanged on exit.
12154 *
12155 * X - DOUBLE PRECISION array of dimension at least
12156 * ( 1 + ( n - 1 )*abs( INCX ) ).
12157 * Before entry, the incremented array X must contain the n
12158 * element vector x.
12159 * Unchanged on exit.
12160 *
12161 * INCX - INTEGER.
12162 * On entry, INCX specifies the increment for the elements of
12163 * X. INCX must not be zero.
12164 * Unchanged on exit.
12165 *
12166 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
12167 * Before entry with UPLO = 'U' or 'u', the leading n by n
12168 * upper triangular part of the array A must contain the upper
12169 * triangular part of the symmetric matrix and the strictly
12170 * lower triangular part of A is not referenced. On exit, the
12171 * upper triangular part of the array A is overwritten by the
12172 * upper triangular part of the updated matrix.
12173 * Before entry with UPLO = 'L' or 'l', the leading n by n
12174 * lower triangular part of the array A must contain the lower
12175 * triangular part of the symmetric matrix and the strictly
12176 * upper triangular part of A is not referenced. On exit, the
12177 * lower triangular part of the array A is overwritten by the
12178 * lower triangular part of the updated matrix.
12179 *
12180 * LDA - INTEGER.
12181 * On entry, LDA specifies the first dimension of A as declared
12182 * in the calling (sub) program. LDA must be at least
12183 * max( 1, n ).
12184 * Unchanged on exit.
12185 *
12186 *
12187 * Level 2 Blas routine.
12188 *
12189 * -- Written on 22-October-1986.
12190 * Jack Dongarra, Argonne National Lab.
12191 * Jeremy Du Croz, Nag Central Office.
12192 * Sven Hammarling, Nag Central Office.
12193 * Richard Hanson, Sandia National Labs.
12194 *
12195 *
12196 * .. Parameters ..
12197  DOUBLE PRECISION ZERO
12198  parameter( zero = 0.0d+0 )
12199 * .. Local Scalars ..
12200  DOUBLE PRECISION TEMP
12201  INTEGER I, INFO, IX, J, JX, KX
12202 * .. External Functions ..
12203  LOGICAL LSAME
12204  EXTERNAL lsame
12205 * .. External Subroutines ..
12206  EXTERNAL xerbla
12207 * .. Intrinsic Functions ..
12208  INTRINSIC max
12209 * ..
12210 * .. Executable Statements ..
12211 *
12212 * Test the input parameters.
12213 *
12214  info = 0
12215  IF ( .NOT.lsame( uplo, 'U' ).AND.
12216  $ .NOT.lsame( uplo, 'L' ) )THEN
12217  info = 1
12218  ELSE IF( n.LT.0 )THEN
12219  info = 2
12220  ELSE IF( incx.EQ.0 )THEN
12221  info = 5
12222  ELSE IF( lda.LT.max( 1, n ) )THEN
12223  info = 7
12224  END IF
12225  IF( info.NE.0 )THEN
12226  CALL xerbla( 'DSYR ', info )
12227  RETURN
12228  END IF
12229 *
12230 * Quick return if possible.
12231 *
12232  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
12233  $ RETURN
12234 *
12235 * Set the start point in X if the increment is not unity.
12236 *
12237  IF( incx.LE.0 )THEN
12238  kx = 1 - ( n - 1 )*incx
12239  ELSE IF( incx.NE.1 )THEN
12240  kx = 1
12241  END IF
12242 *
12243 * Start the operations. In this version the elements of A are
12244 * accessed sequentially with one pass through the triangular part
12245 * of A.
12246 *
12247  IF( lsame( uplo, 'U' ) )THEN
12248 *
12249 * Form A when A is stored in upper triangle.
12250 *
12251  IF( incx.EQ.1 )THEN
12252  DO 20, j = 1, n
12253  IF( x( j ).NE.zero )THEN
12254  temp = alpha*x( j )
12255  DO 10, i = 1, j
12256  a( i, j ) = a( i, j ) + x( i )*temp
12257  10 CONTINUE
12258  END IF
12259  20 CONTINUE
12260  ELSE
12261  jx = kx
12262  DO 40, j = 1, n
12263  IF( x( jx ).NE.zero )THEN
12264  temp = alpha*x( jx )
12265  ix = kx
12266  DO 30, i = 1, j
12267  a( i, j ) = a( i, j ) + x( ix )*temp
12268  ix = ix + incx
12269  30 CONTINUE
12270  END IF
12271  jx = jx + incx
12272  40 CONTINUE
12273  END IF
12274  ELSE
12275 *
12276 * Form A when A is stored in lower triangle.
12277 *
12278  IF( incx.EQ.1 )THEN
12279  DO 60, j = 1, n
12280  IF( x( j ).NE.zero )THEN
12281  temp = alpha*x( j )
12282  DO 50, i = j, n
12283  a( i, j ) = a( i, j ) + x( i )*temp
12284  50 CONTINUE
12285  END IF
12286  60 CONTINUE
12287  ELSE
12288  jx = kx
12289  DO 80, j = 1, n
12290  IF( x( jx ).NE.zero )THEN
12291  temp = alpha*x( jx )
12292  ix = jx
12293  DO 70, i = j, n
12294  a( i, j ) = a( i, j ) + x( ix )*temp
12295  ix = ix + incx
12296  70 CONTINUE
12297  END IF
12298  jx = jx + incx
12299  80 CONTINUE
12300  END IF
12301  END IF
12302 *
12303  RETURN
12304 *
12305 * End of DSYR .
12306 *
12307  END
12308  SUBROUTINE dsyrk ( UPLO, TRANS, N, K, ALPHA, A, LDA,
12309  $ beta, c, ldc )
12310 * .. Scalar Arguments ..
12311  CHARACTER*1 UPLO, TRANS
12312  INTEGER N, K, LDA, LDC
12313  DOUBLE PRECISION ALPHA, BETA
12314 * .. Array Arguments ..
12315  DOUBLE PRECISION A( lda, * ), C( ldc, * )
12316 * ..
12317 *
12318 * Purpose
12319 * =======
12320 *
12321 * DSYRK performs one of the symmetric rank k operations
12322 *
12323 * C := alpha*A*A' + beta*C,
12324 *
12325 * or
12326 *
12327 * C := alpha*A'*A + beta*C,
12328 *
12329 * where alpha and beta are scalars, C is an n by n symmetric matrix
12330 * and A is an n by k matrix in the first case and a k by n matrix
12331 * in the second case.
12332 *
12333 * Parameters
12334 * ==========
12335 *
12336 * UPLO - CHARACTER*1.
12337 * On entry, UPLO specifies whether the upper or lower
12338 * triangular part of the array C is to be referenced as
12339 * follows:
12340 *
12341 * UPLO = 'U' or 'u' Only the upper triangular part of C
12342 * is to be referenced.
12343 *
12344 * UPLO = 'L' or 'l' Only the lower triangular part of C
12345 * is to be referenced.
12346 *
12347 * Unchanged on exit.
12348 *
12349 * TRANS - CHARACTER*1.
12350 * On entry, TRANS specifies the operation to be performed as
12351 * follows:
12352 *
12353 * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
12354 *
12355 * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
12356 *
12357 * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
12358 *
12359 * Unchanged on exit.
12360 *
12361 * N - INTEGER.
12362 * On entry, N specifies the order of the matrix C. N must be
12363 * at least zero.
12364 * Unchanged on exit.
12365 *
12366 * K - INTEGER.
12367 * On entry with TRANS = 'N' or 'n', K specifies the number
12368 * of columns of the matrix A, and on entry with
12369 * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
12370 * of rows of the matrix A. K must be at least zero.
12371 * Unchanged on exit.
12372 *
12373 * ALPHA - DOUBLE PRECISION.
12374 * On entry, ALPHA specifies the scalar alpha.
12375 * Unchanged on exit.
12376 *
12377 * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
12378 * k when TRANS = 'N' or 'n', and is n otherwise.
12379 * Before entry with TRANS = 'N' or 'n', the leading n by k
12380 * part of the array A must contain the matrix A, otherwise
12381 * the leading k by n part of the array A must contain the
12382 * matrix A.
12383 * Unchanged on exit.
12384 *
12385 * LDA - INTEGER.
12386 * On entry, LDA specifies the first dimension of A as declared
12387 * in the calling (sub) program. When TRANS = 'N' or 'n'
12388 * then LDA must be at least max( 1, n ), otherwise LDA must
12389 * be at least max( 1, k ).
12390 * Unchanged on exit.
12391 *
12392 * BETA - DOUBLE PRECISION.
12393 * On entry, BETA specifies the scalar beta.
12394 * Unchanged on exit.
12395 *
12396 * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
12397 * Before entry with UPLO = 'U' or 'u', the leading n by n
12398 * upper triangular part of the array C must contain the upper
12399 * triangular part of the symmetric matrix and the strictly
12400 * lower triangular part of C is not referenced. On exit, the
12401 * upper triangular part of the array C is overwritten by the
12402 * upper triangular part of the updated matrix.
12403 * Before entry with UPLO = 'L' or 'l', the leading n by n
12404 * lower triangular part of the array C must contain the lower
12405 * triangular part of the symmetric matrix and the strictly
12406 * upper triangular part of C is not referenced. On exit, the
12407 * lower triangular part of the array C is overwritten by the
12408 * lower triangular part of the updated matrix.
12409 *
12410 * LDC - INTEGER.
12411 * On entry, LDC specifies the first dimension of C as declared
12412 * in the calling (sub) program. LDC must be at least
12413 * max( 1, n ).
12414 * Unchanged on exit.
12415 *
12416 *
12417 * Level 3 Blas routine.
12418 *
12419 * -- Written on 8-February-1989.
12420 * Jack Dongarra, Argonne National Laboratory.
12421 * Iain Duff, AERE Harwell.
12422 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
12423 * Sven Hammarling, Numerical Algorithms Group Ltd.
12424 *
12425 *
12426 * .. External Functions ..
12427  LOGICAL LSAME
12428  EXTERNAL lsame
12429 * .. External Subroutines ..
12430  EXTERNAL xerbla
12431 * .. Intrinsic Functions ..
12432  INTRINSIC max
12433 * .. Local Scalars ..
12434  LOGICAL UPPER
12435  INTEGER I, INFO, J, L, NROWA
12436  DOUBLE PRECISION TEMP
12437 * .. Parameters ..
12438  DOUBLE PRECISION ONE , ZERO
12439  parameter( one = 1.0d+0, zero = 0.0d+0 )
12440 * ..
12441 * .. Executable Statements ..
12442 *
12443 * Test the input parameters.
12444 *
12445  IF( lsame( trans, 'N' ) )THEN
12446  nrowa = n
12447  ELSE
12448  nrowa = k
12449  END IF
12450  upper = lsame( uplo, 'U' )
12451 *
12452  info = 0
12453  IF( ( .NOT.upper ).AND.
12454  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
12455  info = 1
12456  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
12457  $ ( .NOT.lsame( trans, 'T' ) ).AND.
12458  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
12459  info = 2
12460  ELSE IF( n .LT.0 )THEN
12461  info = 3
12462  ELSE IF( k .LT.0 )THEN
12463  info = 4
12464  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
12465  info = 7
12466  ELSE IF( ldc.LT.max( 1, n ) )THEN
12467  info = 10
12468  END IF
12469  IF( info.NE.0 )THEN
12470  CALL xerbla( 'DSYRK ', info )
12471  RETURN
12472  END IF
12473 *
12474 * Quick return if possible.
12475 *
12476  IF( ( n.EQ.0 ).OR.
12477  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
12478  $ RETURN
12479 *
12480 * And when alpha.eq.zero.
12481 *
12482  IF( alpha.EQ.zero )THEN
12483  IF( upper )THEN
12484  IF( beta.EQ.zero )THEN
12485  DO 20, j = 1, n
12486  DO 10, i = 1, j
12487  c( i, j ) = zero
12488  10 CONTINUE
12489  20 CONTINUE
12490  ELSE
12491  DO 40, j = 1, n
12492  DO 30, i = 1, j
12493  c( i, j ) = beta*c( i, j )
12494  30 CONTINUE
12495  40 CONTINUE
12496  END IF
12497  ELSE
12498  IF( beta.EQ.zero )THEN
12499  DO 60, j = 1, n
12500  DO 50, i = j, n
12501  c( i, j ) = zero
12502  50 CONTINUE
12503  60 CONTINUE
12504  ELSE
12505  DO 80, j = 1, n
12506  DO 70, i = j, n
12507  c( i, j ) = beta*c( i, j )
12508  70 CONTINUE
12509  80 CONTINUE
12510  END IF
12511  END IF
12512  RETURN
12513  END IF
12514 *
12515 * Start the operations.
12516 *
12517  IF( lsame( trans, 'N' ) )THEN
12518 *
12519 * Form C := alpha*A*A' + beta*C.
12520 *
12521  IF( upper )THEN
12522  DO 130, j = 1, n
12523  IF( beta.EQ.zero )THEN
12524  DO 90, i = 1, j
12525  c( i, j ) = zero
12526  90 CONTINUE
12527  ELSE IF( beta.NE.one )THEN
12528  DO 100, i = 1, j
12529  c( i, j ) = beta*c( i, j )
12530  100 CONTINUE
12531  END IF
12532  DO 120, l = 1, k
12533  IF( a( j, l ).NE.zero )THEN
12534  temp = alpha*a( j, l )
12535  DO 110, i = 1, j
12536  c( i, j ) = c( i, j ) + temp*a( i, l )
12537  110 CONTINUE
12538  END IF
12539  120 CONTINUE
12540  130 CONTINUE
12541  ELSE
12542  DO 180, j = 1, n
12543  IF( beta.EQ.zero )THEN
12544  DO 140, i = j, n
12545  c( i, j ) = zero
12546  140 CONTINUE
12547  ELSE IF( beta.NE.one )THEN
12548  DO 150, i = j, n
12549  c( i, j ) = beta*c( i, j )
12550  150 CONTINUE
12551  END IF
12552  DO 170, l = 1, k
12553  IF( a( j, l ).NE.zero )THEN
12554  temp = alpha*a( j, l )
12555  DO 160, i = j, n
12556  c( i, j ) = c( i, j ) + temp*a( i, l )
12557  160 CONTINUE
12558  END IF
12559  170 CONTINUE
12560  180 CONTINUE
12561  END IF
12562  ELSE
12563 *
12564 * Form C := alpha*A'*A + beta*C.
12565 *
12566  IF( upper )THEN
12567  DO 210, j = 1, n
12568  DO 200, i = 1, j
12569  temp = zero
12570  DO 190, l = 1, k
12571  temp = temp + a( l, i )*a( l, j )
12572  190 CONTINUE
12573  IF( beta.EQ.zero )THEN
12574  c( i, j ) = alpha*temp
12575  ELSE
12576  c( i, j ) = alpha*temp + beta*c( i, j )
12577  END IF
12578  200 CONTINUE
12579  210 CONTINUE
12580  ELSE
12581  DO 240, j = 1, n
12582  DO 230, i = j, n
12583  temp = zero
12584  DO 220, l = 1, k
12585  temp = temp + a( l, i )*a( l, j )
12586  220 CONTINUE
12587  IF( beta.EQ.zero )THEN
12588  c( i, j ) = alpha*temp
12589  ELSE
12590  c( i, j ) = alpha*temp + beta*c( i, j )
12591  END IF
12592  230 CONTINUE
12593  240 CONTINUE
12594  END IF
12595  END IF
12596 *
12597  RETURN
12598 *
12599 * End of DSYRK .
12600 *
12601  END
12602  SUBROUTINE dtbmv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
12603 * .. Scalar Arguments ..
12604  INTEGER INCX, K, LDA, N
12605  CHARACTER*1 DIAG, TRANS, UPLO
12606 * .. Array Arguments ..
12607  DOUBLE PRECISION A( lda, * ), X( * )
12608 * ..
12609 *
12610 * Purpose
12611 * =======
12612 *
12613 * DTBMV performs one of the matrix-vector operations
12614 *
12615 * x := A*x, or x := A'*x,
12616 *
12617 * where x is an n element vector and A is an n by n unit, or non-unit,
12618 * upper or lower triangular band matrix, with ( k + 1 ) diagonals.
12619 *
12620 * Parameters
12621 * ==========
12622 *
12623 * UPLO - CHARACTER*1.
12624 * On entry, UPLO specifies whether the matrix is an upper or
12625 * lower triangular matrix as follows:
12626 *
12627 * UPLO = 'U' or 'u' A is an upper triangular matrix.
12628 *
12629 * UPLO = 'L' or 'l' A is a lower triangular matrix.
12630 *
12631 * Unchanged on exit.
12632 *
12633 * TRANS - CHARACTER*1.
12634 * On entry, TRANS specifies the operation to be performed as
12635 * follows:
12636 *
12637 * TRANS = 'N' or 'n' x := A*x.
12638 *
12639 * TRANS = 'T' or 't' x := A'*x.
12640 *
12641 * TRANS = 'C' or 'c' x := A'*x.
12642 *
12643 * Unchanged on exit.
12644 *
12645 * DIAG - CHARACTER*1.
12646 * On entry, DIAG specifies whether or not A is unit
12647 * triangular as follows:
12648 *
12649 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
12650 *
12651 * DIAG = 'N' or 'n' A is not assumed to be unit
12652 * triangular.
12653 *
12654 * Unchanged on exit.
12655 *
12656 * N - INTEGER.
12657 * On entry, N specifies the order of the matrix A.
12658 * N must be at least zero.
12659 * Unchanged on exit.
12660 *
12661 * K - INTEGER.
12662 * On entry with UPLO = 'U' or 'u', K specifies the number of
12663 * super-diagonals of the matrix A.
12664 * On entry with UPLO = 'L' or 'l', K specifies the number of
12665 * sub-diagonals of the matrix A.
12666 * K must satisfy 0 .le. K.
12667 * Unchanged on exit.
12668 *
12669 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
12670 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
12671 * by n part of the array A must contain the upper triangular
12672 * band part of the matrix of coefficients, supplied column by
12673 * column, with the leading diagonal of the matrix in row
12674 * ( k + 1 ) of the array, the first super-diagonal starting at
12675 * position 2 in row k, and so on. The top left k by k triangle
12676 * of the array A is not referenced.
12677 * The following program segment will transfer an upper
12678 * triangular band matrix from conventional full matrix storage
12679 * to band storage:
12680 *
12681 * DO 20, J = 1, N
12682 * M = K + 1 - J
12683 * DO 10, I = MAX( 1, J - K ), J
12684 * A( M + I, J ) = matrix( I, J )
12685 * 10 CONTINUE
12686 * 20 CONTINUE
12687 *
12688 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
12689 * by n part of the array A must contain the lower triangular
12690 * band part of the matrix of coefficients, supplied column by
12691 * column, with the leading diagonal of the matrix in row 1 of
12692 * the array, the first sub-diagonal starting at position 1 in
12693 * row 2, and so on. The bottom right k by k triangle of the
12694 * array A is not referenced.
12695 * The following program segment will transfer a lower
12696 * triangular band matrix from conventional full matrix storage
12697 * to band storage:
12698 *
12699 * DO 20, J = 1, N
12700 * M = 1 - J
12701 * DO 10, I = J, MIN( N, J + K )
12702 * A( M + I, J ) = matrix( I, J )
12703 * 10 CONTINUE
12704 * 20 CONTINUE
12705 *
12706 * Note that when DIAG = 'U' or 'u' the elements of the array A
12707 * corresponding to the diagonal elements of the matrix are not
12708 * referenced, but are assumed to be unity.
12709 * Unchanged on exit.
12710 *
12711 * LDA - INTEGER.
12712 * On entry, LDA specifies the first dimension of A as declared
12713 * in the calling (sub) program. LDA must be at least
12714 * ( k + 1 ).
12715 * Unchanged on exit.
12716 *
12717 * X - DOUBLE PRECISION array of dimension at least
12718 * ( 1 + ( n - 1 )*abs( INCX ) ).
12719 * Before entry, the incremented array X must contain the n
12720 * element vector x. On exit, X is overwritten with the
12721 * tranformed vector x.
12722 *
12723 * INCX - INTEGER.
12724 * On entry, INCX specifies the increment for the elements of
12725 * X. INCX must not be zero.
12726 * Unchanged on exit.
12727 *
12728 *
12729 * Level 2 Blas routine.
12730 *
12731 * -- Written on 22-October-1986.
12732 * Jack Dongarra, Argonne National Lab.
12733 * Jeremy Du Croz, Nag Central Office.
12734 * Sven Hammarling, Nag Central Office.
12735 * Richard Hanson, Sandia National Labs.
12736 *
12737 *
12738 * .. Parameters ..
12739  DOUBLE PRECISION ZERO
12740  parameter( zero = 0.0d+0 )
12741 * .. Local Scalars ..
12742  DOUBLE PRECISION TEMP
12743  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
12744  LOGICAL NOUNIT
12745 * .. External Functions ..
12746  LOGICAL LSAME
12747  EXTERNAL lsame
12748 * .. External Subroutines ..
12749  EXTERNAL xerbla
12750 * .. Intrinsic Functions ..
12751  INTRINSIC max, min
12752 * ..
12753 * .. Executable Statements ..
12754 *
12755 * Test the input parameters.
12756 *
12757  info = 0
12758  IF ( .NOT.lsame( uplo , 'U' ).AND.
12759  $ .NOT.lsame( uplo , 'L' ) )THEN
12760  info = 1
12761  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
12762  $ .NOT.lsame( trans, 'T' ).AND.
12763  $ .NOT.lsame( trans, 'C' ) )THEN
12764  info = 2
12765  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
12766  $ .NOT.lsame( diag , 'N' ) )THEN
12767  info = 3
12768  ELSE IF( n.LT.0 )THEN
12769  info = 4
12770  ELSE IF( k.LT.0 )THEN
12771  info = 5
12772  ELSE IF( lda.LT.( k + 1 ) )THEN
12773  info = 7
12774  ELSE IF( incx.EQ.0 )THEN
12775  info = 9
12776  END IF
12777  IF( info.NE.0 )THEN
12778  CALL xerbla( 'DTBMV ', info )
12779  RETURN
12780  END IF
12781 *
12782 * Quick return if possible.
12783 *
12784  IF( n.EQ.0 )
12785  $ RETURN
12786 *
12787  nounit = lsame( diag, 'N' )
12788 *
12789 * Set up the start point in X if the increment is not unity. This
12790 * will be ( N - 1 )*INCX too small for descending loops.
12791 *
12792  IF( incx.LE.0 )THEN
12793  kx = 1 - ( n - 1 )*incx
12794  ELSE IF( incx.NE.1 )THEN
12795  kx = 1
12796  END IF
12797 *
12798 * Start the operations. In this version the elements of A are
12799 * accessed sequentially with one pass through A.
12800 *
12801  IF( lsame( trans, 'N' ) )THEN
12802 *
12803 * Form x := A*x.
12804 *
12805  IF( lsame( uplo, 'U' ) )THEN
12806  kplus1 = k + 1
12807  IF( incx.EQ.1 )THEN
12808  DO 20, j = 1, n
12809  IF( x( j ).NE.zero )THEN
12810  temp = x( j )
12811  l = kplus1 - j
12812  DO 10, i = max( 1, j - k ), j - 1
12813  x( i ) = x( i ) + temp*a( l + i, j )
12814  10 CONTINUE
12815  IF( nounit )
12816  $ x( j ) = x( j )*a( kplus1, j )
12817  END IF
12818  20 CONTINUE
12819  ELSE
12820  jx = kx
12821  DO 40, j = 1, n
12822  IF( x( jx ).NE.zero )THEN
12823  temp = x( jx )
12824  ix = kx
12825  l = kplus1 - j
12826  DO 30, i = max( 1, j - k ), j - 1
12827  x( ix ) = x( ix ) + temp*a( l + i, j )
12828  ix = ix + incx
12829  30 CONTINUE
12830  IF( nounit )
12831  $ x( jx ) = x( jx )*a( kplus1, j )
12832  END IF
12833  jx = jx + incx
12834  IF( j.GT.k )
12835  $ kx = kx + incx
12836  40 CONTINUE
12837  END IF
12838  ELSE
12839  IF( incx.EQ.1 )THEN
12840  DO 60, j = n, 1, -1
12841  IF( x( j ).NE.zero )THEN
12842  temp = x( j )
12843  l = 1 - j
12844  DO 50, i = min( n, j + k ), j + 1, -1
12845  x( i ) = x( i ) + temp*a( l + i, j )
12846  50 CONTINUE
12847  IF( nounit )
12848  $ x( j ) = x( j )*a( 1, j )
12849  END IF
12850  60 CONTINUE
12851  ELSE
12852  kx = kx + ( n - 1 )*incx
12853  jx = kx
12854  DO 80, j = n, 1, -1
12855  IF( x( jx ).NE.zero )THEN
12856  temp = x( jx )
12857  ix = kx
12858  l = 1 - j
12859  DO 70, i = min( n, j + k ), j + 1, -1
12860  x( ix ) = x( ix ) + temp*a( l + i, j )
12861  ix = ix - incx
12862  70 CONTINUE
12863  IF( nounit )
12864  $ x( jx ) = x( jx )*a( 1, j )
12865  END IF
12866  jx = jx - incx
12867  IF( ( n - j ).GE.k )
12868  $ kx = kx - incx
12869  80 CONTINUE
12870  END IF
12871  END IF
12872  ELSE
12873 *
12874 * Form x := A'*x.
12875 *
12876  IF( lsame( uplo, 'U' ) )THEN
12877  kplus1 = k + 1
12878  IF( incx.EQ.1 )THEN
12879  DO 100, j = n, 1, -1
12880  temp = x( j )
12881  l = kplus1 - j
12882  IF( nounit )
12883  $ temp = temp*a( kplus1, j )
12884  DO 90, i = j - 1, max( 1, j - k ), -1
12885  temp = temp + a( l + i, j )*x( i )
12886  90 CONTINUE
12887  x( j ) = temp
12888  100 CONTINUE
12889  ELSE
12890  kx = kx + ( n - 1 )*incx
12891  jx = kx
12892  DO 120, j = n, 1, -1
12893  temp = x( jx )
12894  kx = kx - incx
12895  ix = kx
12896  l = kplus1 - j
12897  IF( nounit )
12898  $ temp = temp*a( kplus1, j )
12899  DO 110, i = j - 1, max( 1, j - k ), -1
12900  temp = temp + a( l + i, j )*x( ix )
12901  ix = ix - incx
12902  110 CONTINUE
12903  x( jx ) = temp
12904  jx = jx - incx
12905  120 CONTINUE
12906  END IF
12907  ELSE
12908  IF( incx.EQ.1 )THEN
12909  DO 140, j = 1, n
12910  temp = x( j )
12911  l = 1 - j
12912  IF( nounit )
12913  $ temp = temp*a( 1, j )
12914  DO 130, i = j + 1, min( n, j + k )
12915  temp = temp + a( l + i, j )*x( i )
12916  130 CONTINUE
12917  x( j ) = temp
12918  140 CONTINUE
12919  ELSE
12920  jx = kx
12921  DO 160, j = 1, n
12922  temp = x( jx )
12923  kx = kx + incx
12924  ix = kx
12925  l = 1 - j
12926  IF( nounit )
12927  $ temp = temp*a( 1, j )
12928  DO 150, i = j + 1, min( n, j + k )
12929  temp = temp + a( l + i, j )*x( ix )
12930  ix = ix + incx
12931  150 CONTINUE
12932  x( jx ) = temp
12933  jx = jx + incx
12934  160 CONTINUE
12935  END IF
12936  END IF
12937  END IF
12938 *
12939  RETURN
12940 *
12941 * End of DTBMV .
12942 *
12943  END
12944  SUBROUTINE dtbsv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
12945 * .. Scalar Arguments ..
12946  INTEGER INCX, K, LDA, N
12947  CHARACTER*1 DIAG, TRANS, UPLO
12948 * .. Array Arguments ..
12949  DOUBLE PRECISION A( lda, * ), X( * )
12950 * ..
12951 *
12952 * Purpose
12953 * =======
12954 *
12955 * DTBSV solves one of the systems of equations
12956 *
12957 * A*x = b, or A'*x = b,
12958 *
12959 * where b and x are n element vectors and A is an n by n unit, or
12960 * non-unit, upper or lower triangular band matrix, with ( k + 1 )
12961 * diagonals.
12962 *
12963 * No test for singularity or near-singularity is included in this
12964 * routine. Such tests must be performed before calling this routine.
12965 *
12966 * Parameters
12967 * ==========
12968 *
12969 * UPLO - CHARACTER*1.
12970 * On entry, UPLO specifies whether the matrix is an upper or
12971 * lower triangular matrix as follows:
12972 *
12973 * UPLO = 'U' or 'u' A is an upper triangular matrix.
12974 *
12975 * UPLO = 'L' or 'l' A is a lower triangular matrix.
12976 *
12977 * Unchanged on exit.
12978 *
12979 * TRANS - CHARACTER*1.
12980 * On entry, TRANS specifies the equations to be solved as
12981 * follows:
12982 *
12983 * TRANS = 'N' or 'n' A*x = b.
12984 *
12985 * TRANS = 'T' or 't' A'*x = b.
12986 *
12987 * TRANS = 'C' or 'c' A'*x = b.
12988 *
12989 * Unchanged on exit.
12990 *
12991 * DIAG - CHARACTER*1.
12992 * On entry, DIAG specifies whether or not A is unit
12993 * triangular as follows:
12994 *
12995 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
12996 *
12997 * DIAG = 'N' or 'n' A is not assumed to be unit
12998 * triangular.
12999 *
13000 * Unchanged on exit.
13001 *
13002 * N - INTEGER.
13003 * On entry, N specifies the order of the matrix A.
13004 * N must be at least zero.
13005 * Unchanged on exit.
13006 *
13007 * K - INTEGER.
13008 * On entry with UPLO = 'U' or 'u', K specifies the number of
13009 * super-diagonals of the matrix A.
13010 * On entry with UPLO = 'L' or 'l', K specifies the number of
13011 * sub-diagonals of the matrix A.
13012 * K must satisfy 0 .le. K.
13013 * Unchanged on exit.
13014 *
13015 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
13016 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
13017 * by n part of the array A must contain the upper triangular
13018 * band part of the matrix of coefficients, supplied column by
13019 * column, with the leading diagonal of the matrix in row
13020 * ( k + 1 ) of the array, the first super-diagonal starting at
13021 * position 2 in row k, and so on. The top left k by k triangle
13022 * of the array A is not referenced.
13023 * The following program segment will transfer an upper
13024 * triangular band matrix from conventional full matrix storage
13025 * to band storage:
13026 *
13027 * DO 20, J = 1, N
13028 * M = K + 1 - J
13029 * DO 10, I = MAX( 1, J - K ), J
13030 * A( M + I, J ) = matrix( I, J )
13031 * 10 CONTINUE
13032 * 20 CONTINUE
13033 *
13034 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
13035 * by n part of the array A must contain the lower triangular
13036 * band part of the matrix of coefficients, supplied column by
13037 * column, with the leading diagonal of the matrix in row 1 of
13038 * the array, the first sub-diagonal starting at position 1 in
13039 * row 2, and so on. The bottom right k by k triangle of the
13040 * array A is not referenced.
13041 * The following program segment will transfer a lower
13042 * triangular band matrix from conventional full matrix storage
13043 * to band storage:
13044 *
13045 * DO 20, J = 1, N
13046 * M = 1 - J
13047 * DO 10, I = J, MIN( N, J + K )
13048 * A( M + I, J ) = matrix( I, J )
13049 * 10 CONTINUE
13050 * 20 CONTINUE
13051 *
13052 * Note that when DIAG = 'U' or 'u' the elements of the array A
13053 * corresponding to the diagonal elements of the matrix are not
13054 * referenced, but are assumed to be unity.
13055 * Unchanged on exit.
13056 *
13057 * LDA - INTEGER.
13058 * On entry, LDA specifies the first dimension of A as declared
13059 * in the calling (sub) program. LDA must be at least
13060 * ( k + 1 ).
13061 * Unchanged on exit.
13062 *
13063 * X - DOUBLE PRECISION array of dimension at least
13064 * ( 1 + ( n - 1 )*abs( INCX ) ).
13065 * Before entry, the incremented array X must contain the n
13066 * element right-hand side vector b. On exit, X is overwritten
13067 * with the solution vector x.
13068 *
13069 * INCX - INTEGER.
13070 * On entry, INCX specifies the increment for the elements of
13071 * X. INCX must not be zero.
13072 * Unchanged on exit.
13073 *
13074 *
13075 * Level 2 Blas routine.
13076 *
13077 * -- Written on 22-October-1986.
13078 * Jack Dongarra, Argonne National Lab.
13079 * Jeremy Du Croz, Nag Central Office.
13080 * Sven Hammarling, Nag Central Office.
13081 * Richard Hanson, Sandia National Labs.
13082 *
13083 *
13084 * .. Parameters ..
13085  DOUBLE PRECISION ZERO
13086  parameter( zero = 0.0d+0 )
13087 * .. Local Scalars ..
13088  DOUBLE PRECISION TEMP
13089  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
13090  LOGICAL NOUNIT
13091 * .. External Functions ..
13092  LOGICAL LSAME
13093  EXTERNAL lsame
13094 * .. External Subroutines ..
13095  EXTERNAL xerbla
13096 * .. Intrinsic Functions ..
13097  INTRINSIC max, min
13098 * ..
13099 * .. Executable Statements ..
13100 *
13101 * Test the input parameters.
13102 *
13103  info = 0
13104  IF ( .NOT.lsame( uplo , 'U' ).AND.
13105  $ .NOT.lsame( uplo , 'L' ) )THEN
13106  info = 1
13107  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
13108  $ .NOT.lsame( trans, 'T' ).AND.
13109  $ .NOT.lsame( trans, 'C' ) )THEN
13110  info = 2
13111  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
13112  $ .NOT.lsame( diag , 'N' ) )THEN
13113  info = 3
13114  ELSE IF( n.LT.0 )THEN
13115  info = 4
13116  ELSE IF( k.LT.0 )THEN
13117  info = 5
13118  ELSE IF( lda.LT.( k + 1 ) )THEN
13119  info = 7
13120  ELSE IF( incx.EQ.0 )THEN
13121  info = 9
13122  END IF
13123  IF( info.NE.0 )THEN
13124  CALL xerbla( 'DTBSV ', info )
13125  RETURN
13126  END IF
13127 *
13128 * Quick return if possible.
13129 *
13130  IF( n.EQ.0 )
13131  $ RETURN
13132 *
13133  nounit = lsame( diag, 'N' )
13134 *
13135 * Set up the start point in X if the increment is not unity. This
13136 * will be ( N - 1 )*INCX too small for descending loops.
13137 *
13138  IF( incx.LE.0 )THEN
13139  kx = 1 - ( n - 1 )*incx
13140  ELSE IF( incx.NE.1 )THEN
13141  kx = 1
13142  END IF
13143 *
13144 * Start the operations. In this version the elements of A are
13145 * accessed by sequentially with one pass through A.
13146 *
13147  IF( lsame( trans, 'N' ) )THEN
13148 *
13149 * Form x := inv( A )*x.
13150 *
13151  IF( lsame( uplo, 'U' ) )THEN
13152  kplus1 = k + 1
13153  IF( incx.EQ.1 )THEN
13154  DO 20, j = n, 1, -1
13155  IF( x( j ).NE.zero )THEN
13156  l = kplus1 - j
13157  IF( nounit )
13158  $ x( j ) = x( j )/a( kplus1, j )
13159  temp = x( j )
13160  DO 10, i = j - 1, max( 1, j - k ), -1
13161  x( i ) = x( i ) - temp*a( l + i, j )
13162  10 CONTINUE
13163  END IF
13164  20 CONTINUE
13165  ELSE
13166  kx = kx + ( n - 1 )*incx
13167  jx = kx
13168  DO 40, j = n, 1, -1
13169  kx = kx - incx
13170  IF( x( jx ).NE.zero )THEN
13171  ix = kx
13172  l = kplus1 - j
13173  IF( nounit )
13174  $ x( jx ) = x( jx )/a( kplus1, j )
13175  temp = x( jx )
13176  DO 30, i = j - 1, max( 1, j - k ), -1
13177  x( ix ) = x( ix ) - temp*a( l + i, j )
13178  ix = ix - incx
13179  30 CONTINUE
13180  END IF
13181  jx = jx - incx
13182  40 CONTINUE
13183  END IF
13184  ELSE
13185  IF( incx.EQ.1 )THEN
13186  DO 60, j = 1, n
13187  IF( x( j ).NE.zero )THEN
13188  l = 1 - j
13189  IF( nounit )
13190  $ x( j ) = x( j )/a( 1, j )
13191  temp = x( j )
13192  DO 50, i = j + 1, min( n, j + k )
13193  x( i ) = x( i ) - temp*a( l + i, j )
13194  50 CONTINUE
13195  END IF
13196  60 CONTINUE
13197  ELSE
13198  jx = kx
13199  DO 80, j = 1, n
13200  kx = kx + incx
13201  IF( x( jx ).NE.zero )THEN
13202  ix = kx
13203  l = 1 - j
13204  IF( nounit )
13205  $ x( jx ) = x( jx )/a( 1, j )
13206  temp = x( jx )
13207  DO 70, i = j + 1, min( n, j + k )
13208  x( ix ) = x( ix ) - temp*a( l + i, j )
13209  ix = ix + incx
13210  70 CONTINUE
13211  END IF
13212  jx = jx + incx
13213  80 CONTINUE
13214  END IF
13215  END IF
13216  ELSE
13217 *
13218 * Form x := inv( A')*x.
13219 *
13220  IF( lsame( uplo, 'U' ) )THEN
13221  kplus1 = k + 1
13222  IF( incx.EQ.1 )THEN
13223  DO 100, j = 1, n
13224  temp = x( j )
13225  l = kplus1 - j
13226  DO 90, i = max( 1, j - k ), j - 1
13227  temp = temp - a( l + i, j )*x( i )
13228  90 CONTINUE
13229  IF( nounit )
13230  $ temp = temp/a( kplus1, j )
13231  x( j ) = temp
13232  100 CONTINUE
13233  ELSE
13234  jx = kx
13235  DO 120, j = 1, n
13236  temp = x( jx )
13237  ix = kx
13238  l = kplus1 - j
13239  DO 110, i = max( 1, j - k ), j - 1
13240  temp = temp - a( l + i, j )*x( ix )
13241  ix = ix + incx
13242  110 CONTINUE
13243  IF( nounit )
13244  $ temp = temp/a( kplus1, j )
13245  x( jx ) = temp
13246  jx = jx + incx
13247  IF( j.GT.k )
13248  $ kx = kx + incx
13249  120 CONTINUE
13250  END IF
13251  ELSE
13252  IF( incx.EQ.1 )THEN
13253  DO 140, j = n, 1, -1
13254  temp = x( j )
13255  l = 1 - j
13256  DO 130, i = min( n, j + k ), j + 1, -1
13257  temp = temp - a( l + i, j )*x( i )
13258  130 CONTINUE
13259  IF( nounit )
13260  $ temp = temp/a( 1, j )
13261  x( j ) = temp
13262  140 CONTINUE
13263  ELSE
13264  kx = kx + ( n - 1 )*incx
13265  jx = kx
13266  DO 160, j = n, 1, -1
13267  temp = x( jx )
13268  ix = kx
13269  l = 1 - j
13270  DO 150, i = min( n, j + k ), j + 1, -1
13271  temp = temp - a( l + i, j )*x( ix )
13272  ix = ix - incx
13273  150 CONTINUE
13274  IF( nounit )
13275  $ temp = temp/a( 1, j )
13276  x( jx ) = temp
13277  jx = jx - incx
13278  IF( ( n - j ).GE.k )
13279  $ kx = kx - incx
13280  160 CONTINUE
13281  END IF
13282  END IF
13283  END IF
13284 *
13285  RETURN
13286 *
13287 * End of DTBSV .
13288 *
13289  END
13290  SUBROUTINE dtpmv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
13291 * .. Scalar Arguments ..
13292  INTEGER INCX, N
13293  CHARACTER*1 DIAG, TRANS, UPLO
13294 * .. Array Arguments ..
13295  DOUBLE PRECISION AP( * ), X( * )
13296 * ..
13297 *
13298 * Purpose
13299 * =======
13300 *
13301 * DTPMV performs one of the matrix-vector operations
13302 *
13303 * x := A*x, or x := A'*x,
13304 *
13305 * where x is an n element vector and A is an n by n unit, or non-unit,
13306 * upper or lower triangular matrix, supplied in packed form.
13307 *
13308 * Parameters
13309 * ==========
13310 *
13311 * UPLO - CHARACTER*1.
13312 * On entry, UPLO specifies whether the matrix is an upper or
13313 * lower triangular matrix as follows:
13314 *
13315 * UPLO = 'U' or 'u' A is an upper triangular matrix.
13316 *
13317 * UPLO = 'L' or 'l' A is a lower triangular matrix.
13318 *
13319 * Unchanged on exit.
13320 *
13321 * TRANS - CHARACTER*1.
13322 * On entry, TRANS specifies the operation to be performed as
13323 * follows:
13324 *
13325 * TRANS = 'N' or 'n' x := A*x.
13326 *
13327 * TRANS = 'T' or 't' x := A'*x.
13328 *
13329 * TRANS = 'C' or 'c' x := A'*x.
13330 *
13331 * Unchanged on exit.
13332 *
13333 * DIAG - CHARACTER*1.
13334 * On entry, DIAG specifies whether or not A is unit
13335 * triangular as follows:
13336 *
13337 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
13338 *
13339 * DIAG = 'N' or 'n' A is not assumed to be unit
13340 * triangular.
13341 *
13342 * Unchanged on exit.
13343 *
13344 * N - INTEGER.
13345 * On entry, N specifies the order of the matrix A.
13346 * N must be at least zero.
13347 * Unchanged on exit.
13348 *
13349 * AP - DOUBLE PRECISION array of DIMENSION at least
13350 * ( ( n*( n + 1 ) )/2 ).
13351 * Before entry with UPLO = 'U' or 'u', the array AP must
13352 * contain the upper triangular matrix packed sequentially,
13353 * column by column, so that AP( 1 ) contains a( 1, 1 ),
13354 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
13355 * respectively, and so on.
13356 * Before entry with UPLO = 'L' or 'l', the array AP must
13357 * contain the lower triangular matrix packed sequentially,
13358 * column by column, so that AP( 1 ) contains a( 1, 1 ),
13359 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
13360 * respectively, and so on.
13361 * Note that when DIAG = 'U' or 'u', the diagonal elements of
13362 * A are not referenced, but are assumed to be unity.
13363 * Unchanged on exit.
13364 *
13365 * X - DOUBLE PRECISION array of dimension at least
13366 * ( 1 + ( n - 1 )*abs( INCX ) ).
13367 * Before entry, the incremented array X must contain the n
13368 * element vector x. On exit, X is overwritten with the
13369 * tranformed vector x.
13370 *
13371 * INCX - INTEGER.
13372 * On entry, INCX specifies the increment for the elements of
13373 * X. INCX must not be zero.
13374 * Unchanged on exit.
13375 *
13376 *
13377 * Level 2 Blas routine.
13378 *
13379 * -- Written on 22-October-1986.
13380 * Jack Dongarra, Argonne National Lab.
13381 * Jeremy Du Croz, Nag Central Office.
13382 * Sven Hammarling, Nag Central Office.
13383 * Richard Hanson, Sandia National Labs.
13384 *
13385 *
13386 * .. Parameters ..
13387  DOUBLE PRECISION ZERO
13388  parameter( zero = 0.0d+0 )
13389 * .. Local Scalars ..
13390  DOUBLE PRECISION TEMP
13391  INTEGER I, INFO, IX, J, JX, K, KK, KX
13392  LOGICAL NOUNIT
13393 * .. External Functions ..
13394  LOGICAL LSAME
13395  EXTERNAL lsame
13396 * .. External Subroutines ..
13397  EXTERNAL xerbla
13398 * ..
13399 * .. Executable Statements ..
13400 *
13401 * Test the input parameters.
13402 *
13403  info = 0
13404  IF ( .NOT.lsame( uplo , 'U' ).AND.
13405  $ .NOT.lsame( uplo , 'L' ) )THEN
13406  info = 1
13407  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
13408  $ .NOT.lsame( trans, 'T' ).AND.
13409  $ .NOT.lsame( trans, 'C' ) )THEN
13410  info = 2
13411  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
13412  $ .NOT.lsame( diag , 'N' ) )THEN
13413  info = 3
13414  ELSE IF( n.LT.0 )THEN
13415  info = 4
13416  ELSE IF( incx.EQ.0 )THEN
13417  info = 7
13418  END IF
13419  IF( info.NE.0 )THEN
13420  CALL xerbla( 'DTPMV ', info )
13421  RETURN
13422  END IF
13423 *
13424 * Quick return if possible.
13425 *
13426  IF( n.EQ.0 )
13427  $ RETURN
13428 *
13429  nounit = lsame( diag, 'N' )
13430 *
13431 * Set up the start point in X if the increment is not unity. This
13432 * will be ( N - 1 )*INCX too small for descending loops.
13433 *
13434  IF( incx.LE.0 )THEN
13435  kx = 1 - ( n - 1 )*incx
13436  ELSE IF( incx.NE.1 )THEN
13437  kx = 1
13438  END IF
13439 *
13440 * Start the operations. In this version the elements of AP are
13441 * accessed sequentially with one pass through AP.
13442 *
13443  IF( lsame( trans, 'N' ) )THEN
13444 *
13445 * Form x:= A*x.
13446 *
13447  IF( lsame( uplo, 'U' ) )THEN
13448  kk =1
13449  IF( incx.EQ.1 )THEN
13450  DO 20, j = 1, n
13451  IF( x( j ).NE.zero )THEN
13452  temp = x( j )
13453  k = kk
13454  DO 10, i = 1, j - 1
13455  x( i ) = x( i ) + temp*ap( k )
13456  k = k + 1
13457  10 CONTINUE
13458  IF( nounit )
13459  $ x( j ) = x( j )*ap( kk + j - 1 )
13460  END IF
13461  kk = kk + j
13462  20 CONTINUE
13463  ELSE
13464  jx = kx
13465  DO 40, j = 1, n
13466  IF( x( jx ).NE.zero )THEN
13467  temp = x( jx )
13468  ix = kx
13469  DO 30, k = kk, kk + j - 2
13470  x( ix ) = x( ix ) + temp*ap( k )
13471  ix = ix + incx
13472  30 CONTINUE
13473  IF( nounit )
13474  $ x( jx ) = x( jx )*ap( kk + j - 1 )
13475  END IF
13476  jx = jx + incx
13477  kk = kk + j
13478  40 CONTINUE
13479  END IF
13480  ELSE
13481  kk = ( n*( n + 1 ) )/2
13482  IF( incx.EQ.1 )THEN
13483  DO 60, j = n, 1, -1
13484  IF( x( j ).NE.zero )THEN
13485  temp = x( j )
13486  k = kk
13487  DO 50, i = n, j + 1, -1
13488  x( i ) = x( i ) + temp*ap( k )
13489  k = k - 1
13490  50 CONTINUE
13491  IF( nounit )
13492  $ x( j ) = x( j )*ap( kk - n + j )
13493  END IF
13494  kk = kk - ( n - j + 1 )
13495  60 CONTINUE
13496  ELSE
13497  kx = kx + ( n - 1 )*incx
13498  jx = kx
13499  DO 80, j = n, 1, -1
13500  IF( x( jx ).NE.zero )THEN
13501  temp = x( jx )
13502  ix = kx
13503  DO 70, k = kk, kk - ( n - ( j + 1 ) ), -1
13504  x( ix ) = x( ix ) + temp*ap( k )
13505  ix = ix - incx
13506  70 CONTINUE
13507  IF( nounit )
13508  $ x( jx ) = x( jx )*ap( kk - n + j )
13509  END IF
13510  jx = jx - incx
13511  kk = kk - ( n - j + 1 )
13512  80 CONTINUE
13513  END IF
13514  END IF
13515  ELSE
13516 *
13517 * Form x := A'*x.
13518 *
13519  IF( lsame( uplo, 'U' ) )THEN
13520  kk = ( n*( n + 1 ) )/2
13521  IF( incx.EQ.1 )THEN
13522  DO 100, j = n, 1, -1
13523  temp = x( j )
13524  IF( nounit )
13525  $ temp = temp*ap( kk )
13526  k = kk - 1
13527  DO 90, i = j - 1, 1, -1
13528  temp = temp + ap( k )*x( i )
13529  k = k - 1
13530  90 CONTINUE
13531  x( j ) = temp
13532  kk = kk - j
13533  100 CONTINUE
13534  ELSE
13535  jx = kx + ( n - 1 )*incx
13536  DO 120, j = n, 1, -1
13537  temp = x( jx )
13538  ix = jx
13539  IF( nounit )
13540  $ temp = temp*ap( kk )
13541  DO 110, k = kk - 1, kk - j + 1, -1
13542  ix = ix - incx
13543  temp = temp + ap( k )*x( ix )
13544  110 CONTINUE
13545  x( jx ) = temp
13546  jx = jx - incx
13547  kk = kk - j
13548  120 CONTINUE
13549  END IF
13550  ELSE
13551  kk = 1
13552  IF( incx.EQ.1 )THEN
13553  DO 140, j = 1, n
13554  temp = x( j )
13555  IF( nounit )
13556  $ temp = temp*ap( kk )
13557  k = kk + 1
13558  DO 130, i = j + 1, n
13559  temp = temp + ap( k )*x( i )
13560  k = k + 1
13561  130 CONTINUE
13562  x( j ) = temp
13563  kk = kk + ( n - j + 1 )
13564  140 CONTINUE
13565  ELSE
13566  jx = kx
13567  DO 160, j = 1, n
13568  temp = x( jx )
13569  ix = jx
13570  IF( nounit )
13571  $ temp = temp*ap( kk )
13572  DO 150, k = kk + 1, kk + n - j
13573  ix = ix + incx
13574  temp = temp + ap( k )*x( ix )
13575  150 CONTINUE
13576  x( jx ) = temp
13577  jx = jx + incx
13578  kk = kk + ( n - j + 1 )
13579  160 CONTINUE
13580  END IF
13581  END IF
13582  END IF
13583 *
13584  RETURN
13585 *
13586 * End of DTPMV .
13587 *
13588  END
13589  SUBROUTINE dtpsv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
13590 * .. Scalar Arguments ..
13591  INTEGER INCX, N
13592  CHARACTER*1 DIAG, TRANS, UPLO
13593 * .. Array Arguments ..
13594  DOUBLE PRECISION AP( * ), X( * )
13595 * ..
13596 *
13597 * Purpose
13598 * =======
13599 *
13600 * DTPSV solves one of the systems of equations
13601 *
13602 * A*x = b, or A'*x = b,
13603 *
13604 * where b and x are n element vectors and A is an n by n unit, or
13605 * non-unit, upper or lower triangular matrix, supplied in packed form.
13606 *
13607 * No test for singularity or near-singularity is included in this
13608 * routine. Such tests must be performed before calling this routine.
13609 *
13610 * Parameters
13611 * ==========
13612 *
13613 * UPLO - CHARACTER*1.
13614 * On entry, UPLO specifies whether the matrix is an upper or
13615 * lower triangular matrix as follows:
13616 *
13617 * UPLO = 'U' or 'u' A is an upper triangular matrix.
13618 *
13619 * UPLO = 'L' or 'l' A is a lower triangular matrix.
13620 *
13621 * Unchanged on exit.
13622 *
13623 * TRANS - CHARACTER*1.
13624 * On entry, TRANS specifies the equations to be solved as
13625 * follows:
13626 *
13627 * TRANS = 'N' or 'n' A*x = b.
13628 *
13629 * TRANS = 'T' or 't' A'*x = b.
13630 *
13631 * TRANS = 'C' or 'c' A'*x = b.
13632 *
13633 * Unchanged on exit.
13634 *
13635 * DIAG - CHARACTER*1.
13636 * On entry, DIAG specifies whether or not A is unit
13637 * triangular as follows:
13638 *
13639 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
13640 *
13641 * DIAG = 'N' or 'n' A is not assumed to be unit
13642 * triangular.
13643 *
13644 * Unchanged on exit.
13645 *
13646 * N - INTEGER.
13647 * On entry, N specifies the order of the matrix A.
13648 * N must be at least zero.
13649 * Unchanged on exit.
13650 *
13651 * AP - DOUBLE PRECISION array of DIMENSION at least
13652 * ( ( n*( n + 1 ) )/2 ).
13653 * Before entry with UPLO = 'U' or 'u', the array AP must
13654 * contain the upper triangular matrix packed sequentially,
13655 * column by column, so that AP( 1 ) contains a( 1, 1 ),
13656 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
13657 * respectively, and so on.
13658 * Before entry with UPLO = 'L' or 'l', the array AP must
13659 * contain the lower triangular matrix packed sequentially,
13660 * column by column, so that AP( 1 ) contains a( 1, 1 ),
13661 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
13662 * respectively, and so on.
13663 * Note that when DIAG = 'U' or 'u', the diagonal elements of
13664 * A are not referenced, but are assumed to be unity.
13665 * Unchanged on exit.
13666 *
13667 * X - DOUBLE PRECISION array of dimension at least
13668 * ( 1 + ( n - 1 )*abs( INCX ) ).
13669 * Before entry, the incremented array X must contain the n
13670 * element right-hand side vector b. On exit, X is overwritten
13671 * with the solution vector x.
13672 *
13673 * INCX - INTEGER.
13674 * On entry, INCX specifies the increment for the elements of
13675 * X. INCX must not be zero.
13676 * Unchanged on exit.
13677 *
13678 *
13679 * Level 2 Blas routine.
13680 *
13681 * -- Written on 22-October-1986.
13682 * Jack Dongarra, Argonne National Lab.
13683 * Jeremy Du Croz, Nag Central Office.
13684 * Sven Hammarling, Nag Central Office.
13685 * Richard Hanson, Sandia National Labs.
13686 *
13687 *
13688 * .. Parameters ..
13689  DOUBLE PRECISION ZERO
13690  parameter( zero = 0.0d+0 )
13691 * .. Local Scalars ..
13692  DOUBLE PRECISION TEMP
13693  INTEGER I, INFO, IX, J, JX, K, KK, KX
13694  LOGICAL NOUNIT
13695 * .. External Functions ..
13696  LOGICAL LSAME
13697  EXTERNAL lsame
13698 * .. External Subroutines ..
13699  EXTERNAL xerbla
13700 * ..
13701 * .. Executable Statements ..
13702 *
13703 * Test the input parameters.
13704 *
13705  info = 0
13706  IF ( .NOT.lsame( uplo , 'U' ).AND.
13707  $ .NOT.lsame( uplo , 'L' ) )THEN
13708  info = 1
13709  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
13710  $ .NOT.lsame( trans, 'T' ).AND.
13711  $ .NOT.lsame( trans, 'C' ) )THEN
13712  info = 2
13713  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
13714  $ .NOT.lsame( diag , 'N' ) )THEN
13715  info = 3
13716  ELSE IF( n.LT.0 )THEN
13717  info = 4
13718  ELSE IF( incx.EQ.0 )THEN
13719  info = 7
13720  END IF
13721  IF( info.NE.0 )THEN
13722  CALL xerbla( 'DTPSV ', info )
13723  RETURN
13724  END IF
13725 *
13726 * Quick return if possible.
13727 *
13728  IF( n.EQ.0 )
13729  $ RETURN
13730 *
13731  nounit = lsame( diag, 'N' )
13732 *
13733 * Set up the start point in X if the increment is not unity. This
13734 * will be ( N - 1 )*INCX too small for descending loops.
13735 *
13736  IF( incx.LE.0 )THEN
13737  kx = 1 - ( n - 1 )*incx
13738  ELSE IF( incx.NE.1 )THEN
13739  kx = 1
13740  END IF
13741 *
13742 * Start the operations. In this version the elements of AP are
13743 * accessed sequentially with one pass through AP.
13744 *
13745  IF( lsame( trans, 'N' ) )THEN
13746 *
13747 * Form x := inv( A )*x.
13748 *
13749  IF( lsame( uplo, 'U' ) )THEN
13750  kk = ( n*( n + 1 ) )/2
13751  IF( incx.EQ.1 )THEN
13752  DO 20, j = n, 1, -1
13753  IF( x( j ).NE.zero )THEN
13754  IF( nounit )
13755  $ x( j ) = x( j )/ap( kk )
13756  temp = x( j )
13757  k = kk - 1
13758  DO 10, i = j - 1, 1, -1
13759  x( i ) = x( i ) - temp*ap( k )
13760  k = k - 1
13761  10 CONTINUE
13762  END IF
13763  kk = kk - j
13764  20 CONTINUE
13765  ELSE
13766  jx = kx + ( n - 1 )*incx
13767  DO 40, j = n, 1, -1
13768  IF( x( jx ).NE.zero )THEN
13769  IF( nounit )
13770  $ x( jx ) = x( jx )/ap( kk )
13771  temp = x( jx )
13772  ix = jx
13773  DO 30, k = kk - 1, kk - j + 1, -1
13774  ix = ix - incx
13775  x( ix ) = x( ix ) - temp*ap( k )
13776  30 CONTINUE
13777  END IF
13778  jx = jx - incx
13779  kk = kk - j
13780  40 CONTINUE
13781  END IF
13782  ELSE
13783  kk = 1
13784  IF( incx.EQ.1 )THEN
13785  DO 60, j = 1, n
13786  IF( x( j ).NE.zero )THEN
13787  IF( nounit )
13788  $ x( j ) = x( j )/ap( kk )
13789  temp = x( j )
13790  k = kk + 1
13791  DO 50, i = j + 1, n
13792  x( i ) = x( i ) - temp*ap( k )
13793  k = k + 1
13794  50 CONTINUE
13795  END IF
13796  kk = kk + ( n - j + 1 )
13797  60 CONTINUE
13798  ELSE
13799  jx = kx
13800  DO 80, j = 1, n
13801  IF( x( jx ).NE.zero )THEN
13802  IF( nounit )
13803  $ x( jx ) = x( jx )/ap( kk )
13804  temp = x( jx )
13805  ix = jx
13806  DO 70, k = kk + 1, kk + n - j
13807  ix = ix + incx
13808  x( ix ) = x( ix ) - temp*ap( k )
13809  70 CONTINUE
13810  END IF
13811  jx = jx + incx
13812  kk = kk + ( n - j + 1 )
13813  80 CONTINUE
13814  END IF
13815  END IF
13816  ELSE
13817 *
13818 * Form x := inv( A' )*x.
13819 *
13820  IF( lsame( uplo, 'U' ) )THEN
13821  kk = 1
13822  IF( incx.EQ.1 )THEN
13823  DO 100, j = 1, n
13824  temp = x( j )
13825  k = kk
13826  DO 90, i = 1, j - 1
13827  temp = temp - ap( k )*x( i )
13828  k = k + 1
13829  90 CONTINUE
13830  IF( nounit )
13831  $ temp = temp/ap( kk + j - 1 )
13832  x( j ) = temp
13833  kk = kk + j
13834  100 CONTINUE
13835  ELSE
13836  jx = kx
13837  DO 120, j = 1, n
13838  temp = x( jx )
13839  ix = kx
13840  DO 110, k = kk, kk + j - 2
13841  temp = temp - ap( k )*x( ix )
13842  ix = ix + incx
13843  110 CONTINUE
13844  IF( nounit )
13845  $ temp = temp/ap( kk + j - 1 )
13846  x( jx ) = temp
13847  jx = jx + incx
13848  kk = kk + j
13849  120 CONTINUE
13850  END IF
13851  ELSE
13852  kk = ( n*( n + 1 ) )/2
13853  IF( incx.EQ.1 )THEN
13854  DO 140, j = n, 1, -1
13855  temp = x( j )
13856  k = kk
13857  DO 130, i = n, j + 1, -1
13858  temp = temp - ap( k )*x( i )
13859  k = k - 1
13860  130 CONTINUE
13861  IF( nounit )
13862  $ temp = temp/ap( kk - n + j )
13863  x( j ) = temp
13864  kk = kk - ( n - j + 1 )
13865  140 CONTINUE
13866  ELSE
13867  kx = kx + ( n - 1 )*incx
13868  jx = kx
13869  DO 160, j = n, 1, -1
13870  temp = x( jx )
13871  ix = kx
13872  DO 150, k = kk, kk - ( n - ( j + 1 ) ), -1
13873  temp = temp - ap( k )*x( ix )
13874  ix = ix - incx
13875  150 CONTINUE
13876  IF( nounit )
13877  $ temp = temp/ap( kk - n + j )
13878  x( jx ) = temp
13879  jx = jx - incx
13880  kk = kk - (n - j + 1 )
13881  160 CONTINUE
13882  END IF
13883  END IF
13884  END IF
13885 *
13886  RETURN
13887 *
13888 * End of DTPSV .
13889 *
13890  END
13891  SUBROUTINE dtrmm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
13892  $ b, ldb )
13893 * .. Scalar Arguments ..
13894  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
13895  INTEGER M, N, LDA, LDB
13896  DOUBLE PRECISION ALPHA
13897 * .. Array Arguments ..
13898  DOUBLE PRECISION A( lda, * ), B( ldb, * )
13899 * ..
13900 *
13901 * Purpose
13902 * =======
13903 *
13904 * DTRMM performs one of the matrix-matrix operations
13905 *
13906 * B := alpha*op( A )*B, or B := alpha*B*op( A ),
13907 *
13908 * where alpha is a scalar, B is an m by n matrix, A is a unit, or
13909 * non-unit, upper or lower triangular matrix and op( A ) is one of
13910 *
13911 * op( A ) = A or op( A ) = A'.
13912 *
13913 * Parameters
13914 * ==========
13915 *
13916 * SIDE - CHARACTER*1.
13917 * On entry, SIDE specifies whether op( A ) multiplies B from
13918 * the left or right as follows:
13919 *
13920 * SIDE = 'L' or 'l' B := alpha*op( A )*B.
13921 *
13922 * SIDE = 'R' or 'r' B := alpha*B*op( A ).
13923 *
13924 * Unchanged on exit.
13925 *
13926 * UPLO - CHARACTER*1.
13927 * On entry, UPLO specifies whether the matrix A is an upper or
13928 * lower triangular matrix as follows:
13929 *
13930 * UPLO = 'U' or 'u' A is an upper triangular matrix.
13931 *
13932 * UPLO = 'L' or 'l' A is a lower triangular matrix.
13933 *
13934 * Unchanged on exit.
13935 *
13936 * TRANSA - CHARACTER*1.
13937 * On entry, TRANSA specifies the form of op( A ) to be used in
13938 * the matrix multiplication as follows:
13939 *
13940 * TRANSA = 'N' or 'n' op( A ) = A.
13941 *
13942 * TRANSA = 'T' or 't' op( A ) = A'.
13943 *
13944 * TRANSA = 'C' or 'c' op( A ) = A'.
13945 *
13946 * Unchanged on exit.
13947 *
13948 * DIAG - CHARACTER*1.
13949 * On entry, DIAG specifies whether or not A is unit triangular
13950 * as follows:
13951 *
13952 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
13953 *
13954 * DIAG = 'N' or 'n' A is not assumed to be unit
13955 * triangular.
13956 *
13957 * Unchanged on exit.
13958 *
13959 * M - INTEGER.
13960 * On entry, M specifies the number of rows of B. M must be at
13961 * least zero.
13962 * Unchanged on exit.
13963 *
13964 * N - INTEGER.
13965 * On entry, N specifies the number of columns of B. N must be
13966 * at least zero.
13967 * Unchanged on exit.
13968 *
13969 * ALPHA - DOUBLE PRECISION.
13970 * On entry, ALPHA specifies the scalar alpha. When alpha is
13971 * zero then A is not referenced and B need not be set before
13972 * entry.
13973 * Unchanged on exit.
13974 *
13975 * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
13976 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
13977 * Before entry with UPLO = 'U' or 'u', the leading k by k
13978 * upper triangular part of the array A must contain the upper
13979 * triangular matrix and the strictly lower triangular part of
13980 * A is not referenced.
13981 * Before entry with UPLO = 'L' or 'l', the leading k by k
13982 * lower triangular part of the array A must contain the lower
13983 * triangular matrix and the strictly upper triangular part of
13984 * A is not referenced.
13985 * Note that when DIAG = 'U' or 'u', the diagonal elements of
13986 * A are not referenced either, but are assumed to be unity.
13987 * Unchanged on exit.
13988 *
13989 * LDA - INTEGER.
13990 * On entry, LDA specifies the first dimension of A as declared
13991 * in the calling (sub) program. When SIDE = 'L' or 'l' then
13992 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
13993 * then LDA must be at least max( 1, n ).
13994 * Unchanged on exit.
13995 *
13996 * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
13997 * Before entry, the leading m by n part of the array B must
13998 * contain the matrix B, and on exit is overwritten by the
13999 * transformed matrix.
14000 *
14001 * LDB - INTEGER.
14002 * On entry, LDB specifies the first dimension of B as declared
14003 * in the calling (sub) program. LDB must be at least
14004 * max( 1, m ).
14005 * Unchanged on exit.
14006 *
14007 *
14008 * Level 3 Blas routine.
14009 *
14010 * -- Written on 8-February-1989.
14011 * Jack Dongarra, Argonne National Laboratory.
14012 * Iain Duff, AERE Harwell.
14013 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
14014 * Sven Hammarling, Numerical Algorithms Group Ltd.
14015 *
14016 *
14017 * .. External Functions ..
14018  LOGICAL LSAME
14019  EXTERNAL lsame
14020 * .. External Subroutines ..
14021  EXTERNAL xerbla
14022 * .. Intrinsic Functions ..
14023  INTRINSIC max
14024 * .. Local Scalars ..
14025  LOGICAL LSIDE, NOUNIT, UPPER
14026  INTEGER I, INFO, J, K, NROWA
14027  DOUBLE PRECISION TEMP
14028 * .. Parameters ..
14029  DOUBLE PRECISION ONE , ZERO
14030  parameter( one = 1.0d+0, zero = 0.0d+0 )
14031 * ..
14032 * .. Executable Statements ..
14033 *
14034 * Test the input parameters.
14035 *
14036  lside = lsame( side , 'L' )
14037  IF( lside )THEN
14038  nrowa = m
14039  ELSE
14040  nrowa = n
14041  END IF
14042  nounit = lsame( diag , 'N' )
14043  upper = lsame( uplo , 'U' )
14044 *
14045  info = 0
14046  IF( ( .NOT.lside ).AND.
14047  $ ( .NOT.lsame( side , 'R' ) ) )THEN
14048  info = 1
14049  ELSE IF( ( .NOT.upper ).AND.
14050  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
14051  info = 2
14052  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
14053  $ ( .NOT.lsame( transa, 'T' ) ).AND.
14054  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
14055  info = 3
14056  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
14057  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
14058  info = 4
14059  ELSE IF( m .LT.0 )THEN
14060  info = 5
14061  ELSE IF( n .LT.0 )THEN
14062  info = 6
14063  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
14064  info = 9
14065  ELSE IF( ldb.LT.max( 1, m ) )THEN
14066  info = 11
14067  END IF
14068  IF( info.NE.0 )THEN
14069  CALL xerbla( 'DTRMM ', info )
14070  RETURN
14071  END IF
14072 *
14073 * Quick return if possible.
14074 *
14075  IF( n.EQ.0 )
14076  $ RETURN
14077 *
14078 * And when alpha.eq.zero.
14079 *
14080  IF( alpha.EQ.zero )THEN
14081  DO 20, j = 1, n
14082  DO 10, i = 1, m
14083  b( i, j ) = zero
14084  10 CONTINUE
14085  20 CONTINUE
14086  RETURN
14087  END IF
14088 *
14089 * Start the operations.
14090 *
14091  IF( lside )THEN
14092  IF( lsame( transa, 'N' ) )THEN
14093 *
14094 * Form B := alpha*A*B.
14095 *
14096  IF( upper )THEN
14097  DO 50, j = 1, n
14098  DO 40, k = 1, m
14099  IF( b( k, j ).NE.zero )THEN
14100  temp = alpha*b( k, j )
14101  DO 30, i = 1, k - 1
14102  b( i, j ) = b( i, j ) + temp*a( i, k )
14103  30 CONTINUE
14104  IF( nounit )
14105  $ temp = temp*a( k, k )
14106  b( k, j ) = temp
14107  END IF
14108  40 CONTINUE
14109  50 CONTINUE
14110  ELSE
14111  DO 80, j = 1, n
14112  DO 70 k = m, 1, -1
14113  IF( b( k, j ).NE.zero )THEN
14114  temp = alpha*b( k, j )
14115  b( k, j ) = temp
14116  IF( nounit )
14117  $ b( k, j ) = b( k, j )*a( k, k )
14118  DO 60, i = k + 1, m
14119  b( i, j ) = b( i, j ) + temp*a( i, k )
14120  60 CONTINUE
14121  END IF
14122  70 CONTINUE
14123  80 CONTINUE
14124  END IF
14125  ELSE
14126 *
14127 * Form B := alpha*A'*B.
14128 *
14129  IF( upper )THEN
14130  DO 110, j = 1, n
14131  DO 100, i = m, 1, -1
14132  temp = b( i, j )
14133  IF( nounit )
14134  $ temp = temp*a( i, i )
14135  DO 90, k = 1, i - 1
14136  temp = temp + a( k, i )*b( k, j )
14137  90 CONTINUE
14138  b( i, j ) = alpha*temp
14139  100 CONTINUE
14140  110 CONTINUE
14141  ELSE
14142  DO 140, j = 1, n
14143  DO 130, i = 1, m
14144  temp = b( i, j )
14145  IF( nounit )
14146  $ temp = temp*a( i, i )
14147  DO 120, k = i + 1, m
14148  temp = temp + a( k, i )*b( k, j )
14149  120 CONTINUE
14150  b( i, j ) = alpha*temp
14151  130 CONTINUE
14152  140 CONTINUE
14153  END IF
14154  END IF
14155  ELSE
14156  IF( lsame( transa, 'N' ) )THEN
14157 *
14158 * Form B := alpha*B*A.
14159 *
14160  IF( upper )THEN
14161  DO 180, j = n, 1, -1
14162  temp = alpha
14163  IF( nounit )
14164  $ temp = temp*a( j, j )
14165  DO 150, i = 1, m
14166  b( i, j ) = temp*b( i, j )
14167  150 CONTINUE
14168  DO 170, k = 1, j - 1
14169  IF( a( k, j ).NE.zero )THEN
14170  temp = alpha*a( k, j )
14171  DO 160, i = 1, m
14172  b( i, j ) = b( i, j ) + temp*b( i, k )
14173  160 CONTINUE
14174  END IF
14175  170 CONTINUE
14176  180 CONTINUE
14177  ELSE
14178  DO 220, j = 1, n
14179  temp = alpha
14180  IF( nounit )
14181  $ temp = temp*a( j, j )
14182  DO 190, i = 1, m
14183  b( i, j ) = temp*b( i, j )
14184  190 CONTINUE
14185  DO 210, k = j + 1, n
14186  IF( a( k, j ).NE.zero )THEN
14187  temp = alpha*a( k, j )
14188  DO 200, i = 1, m
14189  b( i, j ) = b( i, j ) + temp*b( i, k )
14190  200 CONTINUE
14191  END IF
14192  210 CONTINUE
14193  220 CONTINUE
14194  END IF
14195  ELSE
14196 *
14197 * Form B := alpha*B*A'.
14198 *
14199  IF( upper )THEN
14200  DO 260, k = 1, n
14201  DO 240, j = 1, k - 1
14202  IF( a( j, k ).NE.zero )THEN
14203  temp = alpha*a( j, k )
14204  DO 230, i = 1, m
14205  b( i, j ) = b( i, j ) + temp*b( i, k )
14206  230 CONTINUE
14207  END IF
14208  240 CONTINUE
14209  temp = alpha
14210  IF( nounit )
14211  $ temp = temp*a( k, k )
14212  IF( temp.NE.one )THEN
14213  DO 250, i = 1, m
14214  b( i, k ) = temp*b( i, k )
14215  250 CONTINUE
14216  END IF
14217  260 CONTINUE
14218  ELSE
14219  DO 300, k = n, 1, -1
14220  DO 280, j = k + 1, n
14221  IF( a( j, k ).NE.zero )THEN
14222  temp = alpha*a( j, k )
14223  DO 270, i = 1, m
14224  b( i, j ) = b( i, j ) + temp*b( i, k )
14225  270 CONTINUE
14226  END IF
14227  280 CONTINUE
14228  temp = alpha
14229  IF( nounit )
14230  $ temp = temp*a( k, k )
14231  IF( temp.NE.one )THEN
14232  DO 290, i = 1, m
14233  b( i, k ) = temp*b( i, k )
14234  290 CONTINUE
14235  END IF
14236  300 CONTINUE
14237  END IF
14238  END IF
14239  END IF
14240 *
14241  RETURN
14242 *
14243 * End of DTRMM .
14244 *
14245  END
14246  SUBROUTINE dtrmv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
14247 * .. Scalar Arguments ..
14248  INTEGER INCX, LDA, N
14249  CHARACTER*1 DIAG, TRANS, UPLO
14250 * .. Array Arguments ..
14251  DOUBLE PRECISION A( lda, * ), X( * )
14252 * ..
14253 *
14254 * Purpose
14255 * =======
14256 *
14257 * DTRMV performs one of the matrix-vector operations
14258 *
14259 * x := A*x, or x := A'*x,
14260 *
14261 * where x is an n element vector and A is an n by n unit, or non-unit,
14262 * upper or lower triangular matrix.
14263 *
14264 * Parameters
14265 * ==========
14266 *
14267 * UPLO - CHARACTER*1.
14268 * On entry, UPLO specifies whether the matrix is an upper or
14269 * lower triangular matrix as follows:
14270 *
14271 * UPLO = 'U' or 'u' A is an upper triangular matrix.
14272 *
14273 * UPLO = 'L' or 'l' A is a lower triangular matrix.
14274 *
14275 * Unchanged on exit.
14276 *
14277 * TRANS - CHARACTER*1.
14278 * On entry, TRANS specifies the operation to be performed as
14279 * follows:
14280 *
14281 * TRANS = 'N' or 'n' x := A*x.
14282 *
14283 * TRANS = 'T' or 't' x := A'*x.
14284 *
14285 * TRANS = 'C' or 'c' x := A'*x.
14286 *
14287 * Unchanged on exit.
14288 *
14289 * DIAG - CHARACTER*1.
14290 * On entry, DIAG specifies whether or not A is unit
14291 * triangular as follows:
14292 *
14293 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
14294 *
14295 * DIAG = 'N' or 'n' A is not assumed to be unit
14296 * triangular.
14297 *
14298 * Unchanged on exit.
14299 *
14300 * N - INTEGER.
14301 * On entry, N specifies the order of the matrix A.
14302 * N must be at least zero.
14303 * Unchanged on exit.
14304 *
14305 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
14306 * Before entry with UPLO = 'U' or 'u', the leading n by n
14307 * upper triangular part of the array A must contain the upper
14308 * triangular matrix and the strictly lower triangular part of
14309 * A is not referenced.
14310 * Before entry with UPLO = 'L' or 'l', the leading n by n
14311 * lower triangular part of the array A must contain the lower
14312 * triangular matrix and the strictly upper triangular part of
14313 * A is not referenced.
14314 * Note that when DIAG = 'U' or 'u', the diagonal elements of
14315 * A are not referenced either, but are assumed to be unity.
14316 * Unchanged on exit.
14317 *
14318 * LDA - INTEGER.
14319 * On entry, LDA specifies the first dimension of A as declared
14320 * in the calling (sub) program. LDA must be at least
14321 * max( 1, n ).
14322 * Unchanged on exit.
14323 *
14324 * X - DOUBLE PRECISION array of dimension at least
14325 * ( 1 + ( n - 1 )*abs( INCX ) ).
14326 * Before entry, the incremented array X must contain the n
14327 * element vector x. On exit, X is overwritten with the
14328 * tranformed vector x.
14329 *
14330 * INCX - INTEGER.
14331 * On entry, INCX specifies the increment for the elements of
14332 * X. INCX must not be zero.
14333 * Unchanged on exit.
14334 *
14335 *
14336 * Level 2 Blas routine.
14337 *
14338 * -- Written on 22-October-1986.
14339 * Jack Dongarra, Argonne National Lab.
14340 * Jeremy Du Croz, Nag Central Office.
14341 * Sven Hammarling, Nag Central Office.
14342 * Richard Hanson, Sandia National Labs.
14343 *
14344 *
14345 * .. Parameters ..
14346  DOUBLE PRECISION ZERO
14347  parameter( zero = 0.0d+0 )
14348 * .. Local Scalars ..
14349  DOUBLE PRECISION TEMP
14350  INTEGER I, INFO, IX, J, JX, KX
14351  LOGICAL NOUNIT
14352 * .. External Functions ..
14353  LOGICAL LSAME
14354  EXTERNAL lsame
14355 * .. External Subroutines ..
14356  EXTERNAL xerbla
14357 * .. Intrinsic Functions ..
14358  INTRINSIC max
14359 * ..
14360 * .. Executable Statements ..
14361 *
14362 * Test the input parameters.
14363 *
14364  info = 0
14365  IF ( .NOT.lsame( uplo , 'U' ).AND.
14366  $ .NOT.lsame( uplo , 'L' ) )THEN
14367  info = 1
14368  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
14369  $ .NOT.lsame( trans, 'T' ).AND.
14370  $ .NOT.lsame( trans, 'C' ) )THEN
14371  info = 2
14372  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
14373  $ .NOT.lsame( diag , 'N' ) )THEN
14374  info = 3
14375  ELSE IF( n.LT.0 )THEN
14376  info = 4
14377  ELSE IF( lda.LT.max( 1, n ) )THEN
14378  info = 6
14379  ELSE IF( incx.EQ.0 )THEN
14380  info = 8
14381  END IF
14382  IF( info.NE.0 )THEN
14383  CALL xerbla( 'DTRMV ', info )
14384  RETURN
14385  END IF
14386 *
14387 * Quick return if possible.
14388 *
14389  IF( n.EQ.0 )
14390  $ RETURN
14391 *
14392  nounit = lsame( diag, 'N' )
14393 *
14394 * Set up the start point in X if the increment is not unity. This
14395 * will be ( N - 1 )*INCX too small for descending loops.
14396 *
14397  IF( incx.LE.0 )THEN
14398  kx = 1 - ( n - 1 )*incx
14399  ELSE IF( incx.NE.1 )THEN
14400  kx = 1
14401  END IF
14402 *
14403 * Start the operations. In this version the elements of A are
14404 * accessed sequentially with one pass through A.
14405 *
14406  IF( lsame( trans, 'N' ) )THEN
14407 *
14408 * Form x := A*x.
14409 *
14410  IF( lsame( uplo, 'U' ) )THEN
14411  IF( incx.EQ.1 )THEN
14412  DO 20, j = 1, n
14413  IF( x( j ).NE.zero )THEN
14414  temp = x( j )
14415  DO 10, i = 1, j - 1
14416  x( i ) = x( i ) + temp*a( i, j )
14417  10 CONTINUE
14418  IF( nounit )
14419  $ x( j ) = x( j )*a( j, j )
14420  END IF
14421  20 CONTINUE
14422  ELSE
14423  jx = kx
14424  DO 40, j = 1, n
14425  IF( x( jx ).NE.zero )THEN
14426  temp = x( jx )
14427  ix = kx
14428  DO 30, i = 1, j - 1
14429  x( ix ) = x( ix ) + temp*a( i, j )
14430  ix = ix + incx
14431  30 CONTINUE
14432  IF( nounit )
14433  $ x( jx ) = x( jx )*a( j, j )
14434  END IF
14435  jx = jx + incx
14436  40 CONTINUE
14437  END IF
14438  ELSE
14439  IF( incx.EQ.1 )THEN
14440  DO 60, j = n, 1, -1
14441  IF( x( j ).NE.zero )THEN
14442  temp = x( j )
14443  DO 50, i = n, j + 1, -1
14444  x( i ) = x( i ) + temp*a( i, j )
14445  50 CONTINUE
14446  IF( nounit )
14447  $ x( j ) = x( j )*a( j, j )
14448  END IF
14449  60 CONTINUE
14450  ELSE
14451  kx = kx + ( n - 1 )*incx
14452  jx = kx
14453  DO 80, j = n, 1, -1
14454  IF( x( jx ).NE.zero )THEN
14455  temp = x( jx )
14456  ix = kx
14457  DO 70, i = n, j + 1, -1
14458  x( ix ) = x( ix ) + temp*a( i, j )
14459  ix = ix - incx
14460  70 CONTINUE
14461  IF( nounit )
14462  $ x( jx ) = x( jx )*a( j, j )
14463  END IF
14464  jx = jx - incx
14465  80 CONTINUE
14466  END IF
14467  END IF
14468  ELSE
14469 *
14470 * Form x := A'*x.
14471 *
14472  IF( lsame( uplo, 'U' ) )THEN
14473  IF( incx.EQ.1 )THEN
14474  DO 100, j = n, 1, -1
14475  temp = x( j )
14476  IF( nounit )
14477  $ temp = temp*a( j, j )
14478  DO 90, i = j - 1, 1, -1
14479  temp = temp + a( i, j )*x( i )
14480  90 CONTINUE
14481  x( j ) = temp
14482  100 CONTINUE
14483  ELSE
14484  jx = kx + ( n - 1 )*incx
14485  DO 120, j = n, 1, -1
14486  temp = x( jx )
14487  ix = jx
14488  IF( nounit )
14489  $ temp = temp*a( j, j )
14490  DO 110, i = j - 1, 1, -1
14491  ix = ix - incx
14492  temp = temp + a( i, j )*x( ix )
14493  110 CONTINUE
14494  x( jx ) = temp
14495  jx = jx - incx
14496  120 CONTINUE
14497  END IF
14498  ELSE
14499  IF( incx.EQ.1 )THEN
14500  DO 140, j = 1, n
14501  temp = x( j )
14502  IF( nounit )
14503  $ temp = temp*a( j, j )
14504  DO 130, i = j + 1, n
14505  temp = temp + a( i, j )*x( i )
14506  130 CONTINUE
14507  x( j ) = temp
14508  140 CONTINUE
14509  ELSE
14510  jx = kx
14511  DO 160, j = 1, n
14512  temp = x( jx )
14513  ix = jx
14514  IF( nounit )
14515  $ temp = temp*a( j, j )
14516  DO 150, i = j + 1, n
14517  ix = ix + incx
14518  temp = temp + a( i, j )*x( ix )
14519  150 CONTINUE
14520  x( jx ) = temp
14521  jx = jx + incx
14522  160 CONTINUE
14523  END IF
14524  END IF
14525  END IF
14526 *
14527  RETURN
14528 *
14529 * End of DTRMV .
14530 *
14531  END
14532  SUBROUTINE dtrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
14533  $ b, ldb )
14534 * .. Scalar Arguments ..
14535  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
14536  INTEGER M, N, LDA, LDB
14537  DOUBLE PRECISION ALPHA
14538 * .. Array Arguments ..
14539  DOUBLE PRECISION A( lda, * ), B( ldb, * )
14540 * ..
14541 *
14542 * Purpose
14543 * =======
14544 *
14545 * DTRSM solves one of the matrix equations
14546 *
14547 * op( A )*X = alpha*B, or X*op( A ) = alpha*B,
14548 *
14549 * where alpha is a scalar, X and B are m by n matrices, A is a unit, or
14550 * non-unit, upper or lower triangular matrix and op( A ) is one of
14551 *
14552 * op( A ) = A or op( A ) = A'.
14553 *
14554 * The matrix X is overwritten on B.
14555 *
14556 * Parameters
14557 * ==========
14558 *
14559 * SIDE - CHARACTER*1.
14560 * On entry, SIDE specifies whether op( A ) appears on the left
14561 * or right of X as follows:
14562 *
14563 * SIDE = 'L' or 'l' op( A )*X = alpha*B.
14564 *
14565 * SIDE = 'R' or 'r' X*op( A ) = alpha*B.
14566 *
14567 * Unchanged on exit.
14568 *
14569 * UPLO - CHARACTER*1.
14570 * On entry, UPLO specifies whether the matrix A is an upper or
14571 * lower triangular matrix as follows:
14572 *
14573 * UPLO = 'U' or 'u' A is an upper triangular matrix.
14574 *
14575 * UPLO = 'L' or 'l' A is a lower triangular matrix.
14576 *
14577 * Unchanged on exit.
14578 *
14579 * TRANSA - CHARACTER*1.
14580 * On entry, TRANSA specifies the form of op( A ) to be used in
14581 * the matrix multiplication as follows:
14582 *
14583 * TRANSA = 'N' or 'n' op( A ) = A.
14584 *
14585 * TRANSA = 'T' or 't' op( A ) = A'.
14586 *
14587 * TRANSA = 'C' or 'c' op( A ) = A'.
14588 *
14589 * Unchanged on exit.
14590 *
14591 * DIAG - CHARACTER*1.
14592 * On entry, DIAG specifies whether or not A is unit triangular
14593 * as follows:
14594 *
14595 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
14596 *
14597 * DIAG = 'N' or 'n' A is not assumed to be unit
14598 * triangular.
14599 *
14600 * Unchanged on exit.
14601 *
14602 * M - INTEGER.
14603 * On entry, M specifies the number of rows of B. M must be at
14604 * least zero.
14605 * Unchanged on exit.
14606 *
14607 * N - INTEGER.
14608 * On entry, N specifies the number of columns of B. N must be
14609 * at least zero.
14610 * Unchanged on exit.
14611 *
14612 * ALPHA - DOUBLE PRECISION.
14613 * On entry, ALPHA specifies the scalar alpha. When alpha is
14614 * zero then A is not referenced and B need not be set before
14615 * entry.
14616 * Unchanged on exit.
14617 *
14618 * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
14619 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
14620 * Before entry with UPLO = 'U' or 'u', the leading k by k
14621 * upper triangular part of the array A must contain the upper
14622 * triangular matrix and the strictly lower triangular part of
14623 * A is not referenced.
14624 * Before entry with UPLO = 'L' or 'l', the leading k by k
14625 * lower triangular part of the array A must contain the lower
14626 * triangular matrix and the strictly upper triangular part of
14627 * A is not referenced.
14628 * Note that when DIAG = 'U' or 'u', the diagonal elements of
14629 * A are not referenced either, but are assumed to be unity.
14630 * Unchanged on exit.
14631 *
14632 * LDA - INTEGER.
14633 * On entry, LDA specifies the first dimension of A as declared
14634 * in the calling (sub) program. When SIDE = 'L' or 'l' then
14635 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
14636 * then LDA must be at least max( 1, n ).
14637 * Unchanged on exit.
14638 *
14639 * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
14640 * Before entry, the leading m by n part of the array B must
14641 * contain the right-hand side matrix B, and on exit is
14642 * overwritten by the solution matrix X.
14643 *
14644 * LDB - INTEGER.
14645 * On entry, LDB specifies the first dimension of B as declared
14646 * in the calling (sub) program. LDB must be at least
14647 * max( 1, m ).
14648 * Unchanged on exit.
14649 *
14650 *
14651 * Level 3 Blas routine.
14652 *
14653 *
14654 * -- Written on 8-February-1989.
14655 * Jack Dongarra, Argonne National Laboratory.
14656 * Iain Duff, AERE Harwell.
14657 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
14658 * Sven Hammarling, Numerical Algorithms Group Ltd.
14659 *
14660 *
14661 * .. External Functions ..
14662  LOGICAL LSAME
14663  EXTERNAL lsame
14664 * .. External Subroutines ..
14665  EXTERNAL xerbla
14666 * .. Intrinsic Functions ..
14667  INTRINSIC max
14668 * .. Local Scalars ..
14669  LOGICAL LSIDE, NOUNIT, UPPER
14670  INTEGER I, INFO, J, K, NROWA
14671  DOUBLE PRECISION TEMP
14672 * .. Parameters ..
14673  DOUBLE PRECISION ONE , ZERO
14674  parameter( one = 1.0d+0, zero = 0.0d+0 )
14675 * ..
14676 * .. Executable Statements ..
14677 *
14678 * Test the input parameters.
14679 *
14680  lside = lsame( side , 'L' )
14681  IF( lside )THEN
14682  nrowa = m
14683  ELSE
14684  nrowa = n
14685  END IF
14686  nounit = lsame( diag , 'N' )
14687  upper = lsame( uplo , 'U' )
14688 *
14689  info = 0
14690  IF( ( .NOT.lside ).AND.
14691  $ ( .NOT.lsame( side , 'R' ) ) )THEN
14692  info = 1
14693  ELSE IF( ( .NOT.upper ).AND.
14694  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
14695  info = 2
14696  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
14697  $ ( .NOT.lsame( transa, 'T' ) ).AND.
14698  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
14699  info = 3
14700  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
14701  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
14702  info = 4
14703  ELSE IF( m .LT.0 )THEN
14704  info = 5
14705  ELSE IF( n .LT.0 )THEN
14706  info = 6
14707  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
14708  info = 9
14709  ELSE IF( ldb.LT.max( 1, m ) )THEN
14710  info = 11
14711  END IF
14712  IF( info.NE.0 )THEN
14713  CALL xerbla( 'DTRSM ', info )
14714  RETURN
14715  END IF
14716 *
14717 * Quick return if possible.
14718 *
14719  IF( n.EQ.0 )
14720  $ RETURN
14721 *
14722 * And when alpha.eq.zero.
14723 *
14724  IF( alpha.EQ.zero )THEN
14725  DO 20, j = 1, n
14726  DO 10, i = 1, m
14727  b( i, j ) = zero
14728  10 CONTINUE
14729  20 CONTINUE
14730  RETURN
14731  END IF
14732 *
14733 * Start the operations.
14734 *
14735  IF( lside )THEN
14736  IF( lsame( transa, 'N' ) )THEN
14737 *
14738 * Form B := alpha*inv( A )*B.
14739 *
14740  IF( upper )THEN
14741  DO 60, j = 1, n
14742  IF( alpha.NE.one )THEN
14743  DO 30, i = 1, m
14744  b( i, j ) = alpha*b( i, j )
14745  30 CONTINUE
14746  END IF
14747  DO 50, k = m, 1, -1
14748  IF( b( k, j ).NE.zero )THEN
14749  IF( nounit )
14750  $ b( k, j ) = b( k, j )/a( k, k )
14751  DO 40, i = 1, k - 1
14752  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
14753  40 CONTINUE
14754  END IF
14755  50 CONTINUE
14756  60 CONTINUE
14757  ELSE
14758  DO 100, j = 1, n
14759  IF( alpha.NE.one )THEN
14760  DO 70, i = 1, m
14761  b( i, j ) = alpha*b( i, j )
14762  70 CONTINUE
14763  END IF
14764  DO 90 k = 1, m
14765  IF( b( k, j ).NE.zero )THEN
14766  IF( nounit )
14767  $ b( k, j ) = b( k, j )/a( k, k )
14768  DO 80, i = k + 1, m
14769  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
14770  80 CONTINUE
14771  END IF
14772  90 CONTINUE
14773  100 CONTINUE
14774  END IF
14775  ELSE
14776 *
14777 * Form B := alpha*inv( A' )*B.
14778 *
14779  IF( upper )THEN
14780  DO 130, j = 1, n
14781  DO 120, i = 1, m
14782  temp = alpha*b( i, j )
14783  DO 110, k = 1, i - 1
14784  temp = temp - a( k, i )*b( k, j )
14785  110 CONTINUE
14786  IF( nounit )
14787  $ temp = temp/a( i, i )
14788  b( i, j ) = temp
14789  120 CONTINUE
14790  130 CONTINUE
14791  ELSE
14792  DO 160, j = 1, n
14793  DO 150, i = m, 1, -1
14794  temp = alpha*b( i, j )
14795  DO 140, k = i + 1, m
14796  temp = temp - a( k, i )*b( k, j )
14797  140 CONTINUE
14798  IF( nounit )
14799  $ temp = temp/a( i, i )
14800  b( i, j ) = temp
14801  150 CONTINUE
14802  160 CONTINUE
14803  END IF
14804  END IF
14805  ELSE
14806  IF( lsame( transa, 'N' ) )THEN
14807 *
14808 * Form B := alpha*B*inv( A ).
14809 *
14810  IF( upper )THEN
14811  DO 210, j = 1, n
14812  IF( alpha.NE.one )THEN
14813  DO 170, i = 1, m
14814  b( i, j ) = alpha*b( i, j )
14815  170 CONTINUE
14816  END IF
14817  DO 190, k = 1, j - 1
14818  IF( a( k, j ).NE.zero )THEN
14819  DO 180, i = 1, m
14820  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
14821  180 CONTINUE
14822  END IF
14823  190 CONTINUE
14824  IF( nounit )THEN
14825  temp = one/a( j, j )
14826  DO 200, i = 1, m
14827  b( i, j ) = temp*b( i, j )
14828  200 CONTINUE
14829  END IF
14830  210 CONTINUE
14831  ELSE
14832  DO 260, j = n, 1, -1
14833  IF( alpha.NE.one )THEN
14834  DO 220, i = 1, m
14835  b( i, j ) = alpha*b( i, j )
14836  220 CONTINUE
14837  END IF
14838  DO 240, k = j + 1, n
14839  IF( a( k, j ).NE.zero )THEN
14840  DO 230, i = 1, m
14841  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
14842  230 CONTINUE
14843  END IF
14844  240 CONTINUE
14845  IF( nounit )THEN
14846  temp = one/a( j, j )
14847  DO 250, i = 1, m
14848  b( i, j ) = temp*b( i, j )
14849  250 CONTINUE
14850  END IF
14851  260 CONTINUE
14852  END IF
14853  ELSE
14854 *
14855 * Form B := alpha*B*inv( A' ).
14856 *
14857  IF( upper )THEN
14858  DO 310, k = n, 1, -1
14859  IF( nounit )THEN
14860  temp = one/a( k, k )
14861  DO 270, i = 1, m
14862  b( i, k ) = temp*b( i, k )
14863  270 CONTINUE
14864  END IF
14865  DO 290, j = 1, k - 1
14866  IF( a( j, k ).NE.zero )THEN
14867  temp = a( j, k )
14868  DO 280, i = 1, m
14869  b( i, j ) = b( i, j ) - temp*b( i, k )
14870  280 CONTINUE
14871  END IF
14872  290 CONTINUE
14873  IF( alpha.NE.one )THEN
14874  DO 300, i = 1, m
14875  b( i, k ) = alpha*b( i, k )
14876  300 CONTINUE
14877  END IF
14878  310 CONTINUE
14879  ELSE
14880  DO 360, k = 1, n
14881  IF( nounit )THEN
14882  temp = one/a( k, k )
14883  DO 320, i = 1, m
14884  b( i, k ) = temp*b( i, k )
14885  320 CONTINUE
14886  END IF
14887  DO 340, j = k + 1, n
14888  IF( a( j, k ).NE.zero )THEN
14889  temp = a( j, k )
14890  DO 330, i = 1, m
14891  b( i, j ) = b( i, j ) - temp*b( i, k )
14892  330 CONTINUE
14893  END IF
14894  340 CONTINUE
14895  IF( alpha.NE.one )THEN
14896  DO 350, i = 1, m
14897  b( i, k ) = alpha*b( i, k )
14898  350 CONTINUE
14899  END IF
14900  360 CONTINUE
14901  END IF
14902  END IF
14903  END IF
14904 *
14905  RETURN
14906 *
14907 * End of DTRSM .
14908 *
14909  END
14910  SUBROUTINE dtrsv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
14911 * .. Scalar Arguments ..
14912  INTEGER INCX, LDA, N
14913  CHARACTER*1 DIAG, TRANS, UPLO
14914 * .. Array Arguments ..
14915  DOUBLE PRECISION A( lda, * ), X( * )
14916 * ..
14917 *
14918 * Purpose
14919 * =======
14920 *
14921 * DTRSV solves one of the systems of equations
14922 *
14923 * A*x = b, or A'*x = b,
14924 *
14925 * where b and x are n element vectors and A is an n by n unit, or
14926 * non-unit, upper or lower triangular matrix.
14927 *
14928 * No test for singularity or near-singularity is included in this
14929 * routine. Such tests must be performed before calling this routine.
14930 *
14931 * Parameters
14932 * ==========
14933 *
14934 * UPLO - CHARACTER*1.
14935 * On entry, UPLO specifies whether the matrix is an upper or
14936 * lower triangular matrix as follows:
14937 *
14938 * UPLO = 'U' or 'u' A is an upper triangular matrix.
14939 *
14940 * UPLO = 'L' or 'l' A is a lower triangular matrix.
14941 *
14942 * Unchanged on exit.
14943 *
14944 * TRANS - CHARACTER*1.
14945 * On entry, TRANS specifies the equations to be solved as
14946 * follows:
14947 *
14948 * TRANS = 'N' or 'n' A*x = b.
14949 *
14950 * TRANS = 'T' or 't' A'*x = b.
14951 *
14952 * TRANS = 'C' or 'c' A'*x = b.
14953 *
14954 * Unchanged on exit.
14955 *
14956 * DIAG - CHARACTER*1.
14957 * On entry, DIAG specifies whether or not A is unit
14958 * triangular as follows:
14959 *
14960 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
14961 *
14962 * DIAG = 'N' or 'n' A is not assumed to be unit
14963 * triangular.
14964 *
14965 * Unchanged on exit.
14966 *
14967 * N - INTEGER.
14968 * On entry, N specifies the order of the matrix A.
14969 * N must be at least zero.
14970 * Unchanged on exit.
14971 *
14972 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
14973 * Before entry with UPLO = 'U' or 'u', the leading n by n
14974 * upper triangular part of the array A must contain the upper
14975 * triangular matrix and the strictly lower triangular part of
14976 * A is not referenced.
14977 * Before entry with UPLO = 'L' or 'l', the leading n by n
14978 * lower triangular part of the array A must contain the lower
14979 * triangular matrix and the strictly upper triangular part of
14980 * A is not referenced.
14981 * Note that when DIAG = 'U' or 'u', the diagonal elements of
14982 * A are not referenced either, but are assumed to be unity.
14983 * Unchanged on exit.
14984 *
14985 * LDA - INTEGER.
14986 * On entry, LDA specifies the first dimension of A as declared
14987 * in the calling (sub) program. LDA must be at least
14988 * max( 1, n ).
14989 * Unchanged on exit.
14990 *
14991 * X - DOUBLE PRECISION array of dimension at least
14992 * ( 1 + ( n - 1 )*abs( INCX ) ).
14993 * Before entry, the incremented array X must contain the n
14994 * element right-hand side vector b. On exit, X is overwritten
14995 * with the solution vector x.
14996 *
14997 * INCX - INTEGER.
14998 * On entry, INCX specifies the increment for the elements of
14999 * X. INCX must not be zero.
15000 * Unchanged on exit.
15001 *
15002 *
15003 * Level 2 Blas routine.
15004 *
15005 * -- Written on 22-October-1986.
15006 * Jack Dongarra, Argonne National Lab.
15007 * Jeremy Du Croz, Nag Central Office.
15008 * Sven Hammarling, Nag Central Office.
15009 * Richard Hanson, Sandia National Labs.
15010 *
15011 *
15012 * .. Parameters ..
15013  DOUBLE PRECISION ZERO
15014  parameter( zero = 0.0d+0 )
15015 * .. Local Scalars ..
15016  DOUBLE PRECISION TEMP
15017  INTEGER I, INFO, IX, J, JX, KX
15018  LOGICAL NOUNIT
15019 * .. External Functions ..
15020  LOGICAL LSAME
15021  EXTERNAL lsame
15022 * .. External Subroutines ..
15023  EXTERNAL xerbla
15024 * .. Intrinsic Functions ..
15025  INTRINSIC max
15026 * ..
15027 * .. Executable Statements ..
15028 *
15029 * Test the input parameters.
15030 *
15031  info = 0
15032  IF ( .NOT.lsame( uplo , 'U' ).AND.
15033  $ .NOT.lsame( uplo , 'L' ) )THEN
15034  info = 1
15035  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
15036  $ .NOT.lsame( trans, 'T' ).AND.
15037  $ .NOT.lsame( trans, 'C' ) )THEN
15038  info = 2
15039  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
15040  $ .NOT.lsame( diag , 'N' ) )THEN
15041  info = 3
15042  ELSE IF( n.LT.0 )THEN
15043  info = 4
15044  ELSE IF( lda.LT.max( 1, n ) )THEN
15045  info = 6
15046  ELSE IF( incx.EQ.0 )THEN
15047  info = 8
15048  END IF
15049  IF( info.NE.0 )THEN
15050  CALL xerbla( 'DTRSV ', info )
15051  RETURN
15052  END IF
15053 *
15054 * Quick return if possible.
15055 *
15056  IF( n.EQ.0 )
15057  $ RETURN
15058 *
15059  nounit = lsame( diag, 'N' )
15060 *
15061 * Set up the start point in X if the increment is not unity. This
15062 * will be ( N - 1 )*INCX too small for descending loops.
15063 *
15064  IF( incx.LE.0 )THEN
15065  kx = 1 - ( n - 1 )*incx
15066  ELSE IF( incx.NE.1 )THEN
15067  kx = 1
15068  END IF
15069 *
15070 * Start the operations. In this version the elements of A are
15071 * accessed sequentially with one pass through A.
15072 *
15073  IF( lsame( trans, 'N' ) )THEN
15074 *
15075 * Form x := inv( A )*x.
15076 *
15077  IF( lsame( uplo, 'U' ) )THEN
15078  IF( incx.EQ.1 )THEN
15079  DO 20, j = n, 1, -1
15080  IF( x( j ).NE.zero )THEN
15081  IF( nounit )
15082  $ x( j ) = x( j )/a( j, j )
15083  temp = x( j )
15084  DO 10, i = j - 1, 1, -1
15085  x( i ) = x( i ) - temp*a( i, j )
15086  10 CONTINUE
15087  END IF
15088  20 CONTINUE
15089  ELSE
15090  jx = kx + ( n - 1 )*incx
15091  DO 40, j = n, 1, -1
15092  IF( x( jx ).NE.zero )THEN
15093  IF( nounit )
15094  $ x( jx ) = x( jx )/a( j, j )
15095  temp = x( jx )
15096  ix = jx
15097  DO 30, i = j - 1, 1, -1
15098  ix = ix - incx
15099  x( ix ) = x( ix ) - temp*a( i, j )
15100  30 CONTINUE
15101  END IF
15102  jx = jx - incx
15103  40 CONTINUE
15104  END IF
15105  ELSE
15106  IF( incx.EQ.1 )THEN
15107  DO 60, j = 1, n
15108  IF( x( j ).NE.zero )THEN
15109  IF( nounit )
15110  $ x( j ) = x( j )/a( j, j )
15111  temp = x( j )
15112  DO 50, i = j + 1, n
15113  x( i ) = x( i ) - temp*a( i, j )
15114  50 CONTINUE
15115  END IF
15116  60 CONTINUE
15117  ELSE
15118  jx = kx
15119  DO 80, j = 1, n
15120  IF( x( jx ).NE.zero )THEN
15121  IF( nounit )
15122  $ x( jx ) = x( jx )/a( j, j )
15123  temp = x( jx )
15124  ix = jx
15125  DO 70, i = j + 1, n
15126  ix = ix + incx
15127  x( ix ) = x( ix ) - temp*a( i, j )
15128  70 CONTINUE
15129  END IF
15130  jx = jx + incx
15131  80 CONTINUE
15132  END IF
15133  END IF
15134  ELSE
15135 *
15136 * Form x := inv( A' )*x.
15137 *
15138  IF( lsame( uplo, 'U' ) )THEN
15139  IF( incx.EQ.1 )THEN
15140  DO 100, j = 1, n
15141  temp = x( j )
15142  DO 90, i = 1, j - 1
15143  temp = temp - a( i, j )*x( i )
15144  90 CONTINUE
15145  IF( nounit )
15146  $ temp = temp/a( j, j )
15147  x( j ) = temp
15148  100 CONTINUE
15149  ELSE
15150  jx = kx
15151  DO 120, j = 1, n
15152  temp = x( jx )
15153  ix = kx
15154  DO 110, i = 1, j - 1
15155  temp = temp - a( i, j )*x( ix )
15156  ix = ix + incx
15157  110 CONTINUE
15158  IF( nounit )
15159  $ temp = temp/a( j, j )
15160  x( jx ) = temp
15161  jx = jx + incx
15162  120 CONTINUE
15163  END IF
15164  ELSE
15165  IF( incx.EQ.1 )THEN
15166  DO 140, j = n, 1, -1
15167  temp = x( j )
15168  DO 130, i = n, j + 1, -1
15169  temp = temp - a( i, j )*x( i )
15170  130 CONTINUE
15171  IF( nounit )
15172  $ temp = temp/a( j, j )
15173  x( j ) = temp
15174  140 CONTINUE
15175  ELSE
15176  kx = kx + ( n - 1 )*incx
15177  jx = kx
15178  DO 160, j = n, 1, -1
15179  temp = x( jx )
15180  ix = kx
15181  DO 150, i = n, j + 1, -1
15182  temp = temp - a( i, j )*x( ix )
15183  ix = ix - incx
15184  150 CONTINUE
15185  IF( nounit )
15186  $ temp = temp/a( j, j )
15187  x( jx ) = temp
15188  jx = jx - incx
15189  160 CONTINUE
15190  END IF
15191  END IF
15192  END IF
15193 *
15194  RETURN
15195 *
15196 * End of DTRSV .
15197 *
15198  END
15199  double precision function dzasum(n,zx,incx)
15200 c
15201 c takes the sum of the absolute values.
15202 c jack dongarra, 3/11/78.
15203 c modified 3/93 to return if incx .le. 0.
15204 c modified 12/3/93, array(1) declarations changed to array(*)
15205 c
15206  double complex zx(*)
15207  double precision stemp,dcabs1
15208  integer i,incx,ix,n
15209 c
15210  dzasum = 0.0d0
15211  stemp = 0.0d0
15212  if( n.le.0 .or. incx.le.0 )return
15213  if(incx.eq.1)go to 20
15214 c
15215 c code for increment not equal to 1
15216 c
15217  ix = 1
15218  do 10 i = 1,n
15219  stemp = stemp + dcabs1(zx(ix))
15220  ix = ix + incx
15221  10 continue
15222  dzasum = stemp
15223  return
15224 c
15225 c code for increment equal to 1
15226 c
15227  20 do 30 i = 1,n
15228  stemp = stemp + dcabs1(zx(i))
15229  30 continue
15230  dzasum = stemp
15231  return
15232  end
15233  DOUBLE PRECISION FUNCTION dznrm2( N, X, INCX )
15234 * .. Scalar Arguments ..
15235  INTEGER INCX, N
15236 * .. Array Arguments ..
15237  COMPLEX*16 X( * )
15238 * ..
15239 *
15240 * DZNRM2 returns the euclidean norm of a vector via the function
15241 * name, so that
15242 *
15243 * DZNRM2 := sqrt( conjg( x' )*x )
15244 *
15245 *
15246 *
15247 * -- This version written on 25-October-1982.
15248 * Modified on 14-October-1993 to inline the call to ZLASSQ.
15249 * Sven Hammarling, Nag Ltd.
15250 *
15251 *
15252 * .. Parameters ..
15253  DOUBLE PRECISION ONE , ZERO
15254  parameter( one = 1.0d+0, zero = 0.0d+0 )
15255 * .. Local Scalars ..
15256  INTEGER IX
15257  DOUBLE PRECISION NORM, SCALE, SSQ, TEMP
15258 * .. Intrinsic Functions ..
15259  INTRINSIC abs, dimag, dble, sqrt
15260 * ..
15261 * .. Executable Statements ..
15262  IF( n.LT.1 .OR. incx.LT.1 )THEN
15263  norm = zero
15264  ELSE
15265  scale = zero
15266  ssq = one
15267 * The following loop is equivalent to this call to the LAPACK
15268 * auxiliary routine:
15269 * CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
15270 *
15271  DO 10, ix = 1, 1 + ( n - 1 )*incx, incx
15272  IF( dble( x( ix ) ).NE.zero )THEN
15273  temp = abs( dble( x( ix ) ) )
15274  IF( scale.LT.temp )THEN
15275  ssq = one + ssq*( scale/temp )**2
15276  scale = temp
15277  ELSE
15278  ssq = ssq + ( temp/scale )**2
15279  END IF
15280  END IF
15281  IF( dimag( x( ix ) ).NE.zero )THEN
15282  temp = abs( dimag( x( ix ) ) )
15283  IF( scale.LT.temp )THEN
15284  ssq = one + ssq*( scale/temp )**2
15285  scale = temp
15286  ELSE
15287  ssq = ssq + ( temp/scale )**2
15288  END IF
15289  END IF
15290  10 CONTINUE
15291  norm = scale * sqrt( ssq )
15292  END IF
15293 *
15294  dznrm2 = norm
15295  RETURN
15296 *
15297 * End of DZNRM2.
15298 *
15299  END
15300  integer function icamax(n,cx,incx)
15301 c
15302 c finds the index of element having max. absolute value.
15303 c jack dongarra, linpack, 3/11/78.
15304 c modified 3/93 to return if incx .le. 0.
15305 c modified 12/3/93, array(1) declarations changed to array(*)
15306 c
15307  complex cx(*)
15308  real smax
15309  integer i,incx,ix,n
15310  complex zdum
15311  real cabs1
15312  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
15313 c
15314  icamax = 0
15315  if( n.lt.1 .or. incx.le.0 ) return
15316  icamax = 1
15317  if(n.eq.1)return
15318  if(incx.eq.1)go to 20
15319 c
15320 c code for increment not equal to 1
15321 c
15322  ix = 1
15323  smax = cabs1(cx(1))
15324  ix = ix + incx
15325  do 10 i = 2,n
15326  if(cabs1(cx(ix)).le.smax) go to 5
15327  icamax = i
15328  smax = cabs1(cx(ix))
15329  5 ix = ix + incx
15330  10 continue
15331  return
15332 c
15333 c code for increment equal to 1
15334 c
15335  20 smax = cabs1(cx(1))
15336  do 30 i = 2,n
15337  if(cabs1(cx(i)).le.smax) go to 30
15338  icamax = i
15339  smax = cabs1(cx(i))
15340  30 continue
15341  return
15342  end
15343  integer function idamax(n,dx,incx)
15344 c
15345 c finds the index of element having max. absolute value.
15346 c jack dongarra, linpack, 3/11/78.
15347 c modified 3/93 to return if incx .le. 0.
15348 c modified 12/3/93, array(1) declarations changed to array(*)
15349 c
15350  double precision dx(*),dmax
15351  integer i,incx,ix,n
15352 c
15353  idamax = 0
15354  if( n.lt.1 .or. incx.le.0 ) return
15355  idamax = 1
15356  if(n.eq.1)return
15357  if(incx.eq.1)go to 20
15358 c
15359 c code for increment not equal to 1
15360 c
15361  ix = 1
15362  dmax = dabs(dx(1))
15363  ix = ix + incx
15364  do 10 i = 2,n
15365  if(dabs(dx(ix)).le.dmax) go to 5
15366  idamax = i
15367  dmax = dabs(dx(ix))
15368  5 ix = ix + incx
15369  10 continue
15370  return
15371 c
15372 c code for increment equal to 1
15373 c
15374  20 dmax = dabs(dx(1))
15375  do 30 i = 2,n
15376  if(dabs(dx(i)).le.dmax) go to 30
15377  idamax = i
15378  dmax = dabs(dx(i))
15379  30 continue
15380  return
15381  end
15382  integer function isamax(n,sx,incx)
15383 c
15384 c finds the index of element having max. absolute value.
15385 c jack dongarra, linpack, 3/11/78.
15386 c modified 3/93 to return if incx .le. 0.
15387 c modified 12/3/93, array(1) declarations changed to array(*)
15388 c
15389  real sx(*),smax
15390  integer i,incx,ix,n
15391 c
15392  isamax = 0
15393  if( n.lt.1 .or. incx.le.0 ) return
15394  isamax = 1
15395  if(n.eq.1)return
15396  if(incx.eq.1)go to 20
15397 c
15398 c code for increment not equal to 1
15399 c
15400  ix = 1
15401  smax = abs(sx(1))
15402  ix = ix + incx
15403  do 10 i = 2,n
15404  if(abs(sx(ix)).le.smax) go to 5
15405  isamax = i
15406  smax = abs(sx(ix))
15407  5 ix = ix + incx
15408  10 continue
15409  return
15410 c
15411 c code for increment equal to 1
15412 c
15413  20 smax = abs(sx(1))
15414  do 30 i = 2,n
15415  if(abs(sx(i)).le.smax) go to 30
15416  isamax = i
15417  smax = abs(sx(i))
15418  30 continue
15419  return
15420  end
15421  integer function izamax(n,zx,incx)
15422 c
15423 c finds the index of element having max. absolute value.
15424 c jack dongarra, 1/15/85.
15425 c modified 3/93 to return if incx .le. 0.
15426 c modified 12/3/93, array(1) declarations changed to array(*)
15427 c
15428  double complex zx(*)
15429  double precision smax
15430  integer i,incx,ix,n
15431  double precision dcabs1
15432 c
15433  izamax = 0
15434  if( n.lt.1 .or. incx.le.0 )return
15435  izamax = 1
15436  if(n.eq.1)return
15437  if(incx.eq.1)go to 20
15438 c
15439 c code for increment not equal to 1
15440 c
15441  ix = 1
15442  smax = dcabs1(zx(1))
15443  ix = ix + incx
15444  do 10 i = 2,n
15445  if(dcabs1(zx(ix)).le.smax) go to 5
15446  izamax = i
15447  smax = dcabs1(zx(ix))
15448  5 ix = ix + incx
15449  10 continue
15450  return
15451 c
15452 c code for increment equal to 1
15453 c
15454  20 smax = dcabs1(zx(1))
15455  do 30 i = 2,n
15456  if(dcabs1(zx(i)).le.smax) go to 30
15457  izamax = i
15458  smax = dcabs1(zx(i))
15459  30 continue
15460  return
15461  end
15462  LOGICAL FUNCTION lsame( CA, CB )
15463 *
15464 * -- LAPACK auxiliary routine (version 2.0) --
15465 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
15466 * Courant Institute, Argonne National Lab, and Rice University
15467 * January 31, 1994
15468 *
15469 * .. Scalar Arguments ..
15470  CHARACTER CA, CB
15471 * ..
15472 *
15473 * Purpose
15474 * =======
15475 *
15476 * LSAME returns .TRUE. if CA is the same letter as CB regardless of
15477 * case.
15478 *
15479 * Arguments
15480 * =========
15481 *
15482 * CA (input) CHARACTER*1
15483 * CB (input) CHARACTER*1
15484 * CA and CB specify the single characters to be compared.
15485 *
15486 * =====================================================================
15487 *
15488 * .. Intrinsic Functions ..
15489  INTRINSIC ichar
15490 * ..
15491 * .. Local Scalars ..
15492  INTEGER INTA, INTB, ZCODE
15493 * ..
15494 * .. Executable Statements ..
15495 *
15496 * Test if the characters are equal
15497 *
15498  lsame = ca.EQ.cb
15499  IF( lsame )
15500  $ RETURN
15501 *
15502 * Now test for equivalence if both characters are alphabetic.
15503 *
15504  zcode = ichar( 'Z' )
15505 *
15506 * Use 'Z' rather than 'A' so that ASCII can be detected on Prime
15507 * machines, on which ICHAR returns a value with bit 8 set.
15508 * ICHAR('A') on Prime machines returns 193 which is the same as
15509 * ICHAR('A') on an EBCDIC machine.
15510 *
15511  inta = ichar( ca )
15512  intb = ichar( cb )
15513 *
15514  IF( zcode.EQ.90 .OR. zcode.EQ.122 ) THEN
15515 *
15516 * ASCII is assumed - ZCODE is the ASCII code of either lower or
15517 * upper case 'Z'.
15518 *
15519  IF( inta.GE.97 .AND. inta.LE.122 ) inta = inta - 32
15520  IF( intb.GE.97 .AND. intb.LE.122 ) intb = intb - 32
15521 *
15522  ELSE IF( zcode.EQ.233 .OR. zcode.EQ.169 ) THEN
15523 *
15524 * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
15525 * upper case 'Z'.
15526 *
15527  IF( inta.GE.129 .AND. inta.LE.137 .OR.
15528  $ inta.GE.145 .AND. inta.LE.153 .OR.
15529  $ inta.GE.162 .AND. inta.LE.169 ) inta = inta + 64
15530  IF( intb.GE.129 .AND. intb.LE.137 .OR.
15531  $ intb.GE.145 .AND. intb.LE.153 .OR.
15532  $ intb.GE.162 .AND. intb.LE.169 ) intb = intb + 64
15533 *
15534  ELSE IF( zcode.EQ.218 .OR. zcode.EQ.250 ) THEN
15535 *
15536 * ASCII is assumed, on Prime machines - ZCODE is the ASCII code
15537 * plus 128 of either lower or upper case 'Z'.
15538 *
15539  IF( inta.GE.225 .AND. inta.LE.250 ) inta = inta - 32
15540  IF( intb.GE.225 .AND. intb.LE.250 ) intb = intb - 32
15541  END IF
15542  lsame = inta.EQ.intb
15543 *
15544 * RETURN
15545 *
15546 * End of LSAME
15547 *
15548  END
15549  real function sasum(n,sx,incx)
15550 c
15551 c takes the sum of the absolute values.
15552 c uses unrolled loops for increment equal to one.
15553 c jack dongarra, linpack, 3/11/78.
15554 c modified 3/93 to return if incx .le. 0.
15555 c modified 12/3/93, array(1) declarations changed to array(*)
15556 c
15557  real sx(*),stemp
15558  integer i,incx,m,mp1,n,nincx
15559 c
15560  sasum = 0.0e0
15561  stemp = 0.0e0
15562  if( n.le.0 .or. incx.le.0 )return
15563  if(incx.eq.1)go to 20
15564 c
15565 c code for increment not equal to 1
15566 c
15567  nincx = n*incx
15568  do 10 i = 1,nincx,incx
15569  stemp = stemp + abs(sx(i))
15570  10 continue
15571  sasum = stemp
15572  return
15573 c
15574 c code for increment equal to 1
15575 c
15576 c
15577 c clean-up loop
15578 c
15579  20 m = mod(n,6)
15580  if( m .eq. 0 ) go to 40
15581  do 30 i = 1,m
15582  stemp = stemp + abs(sx(i))
15583  30 continue
15584  if( n .lt. 6 ) go to 60
15585  40 mp1 = m + 1
15586  do 50 i = mp1,n,6
15587  stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2))
15588  * + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5))
15589  50 continue
15590  60 sasum = stemp
15591  return
15592  end
15593  subroutine saxpy(n,sa,sx,incx,sy,incy)
15594 c
15595 c constant times a vector plus a vector.
15596 c uses unrolled loop for increments equal to one.
15597 c jack dongarra, linpack, 3/11/78.
15598 c modified 12/3/93, array(1) declarations changed to array(*)
15599 c
15600  real sx(*),sy(*),sa
15601  integer i,incx,incy,ix,iy,m,mp1,n
15602 c
15603  if(n.le.0)return
15604  if (sa .eq. 0.0) return
15605  if(incx.eq.1.and.incy.eq.1)go to 20
15606 c
15607 c code for unequal increments or equal increments
15608 c not equal to 1
15609 c
15610  ix = 1
15611  iy = 1
15612  if(incx.lt.0)ix = (-n+1)*incx + 1
15613  if(incy.lt.0)iy = (-n+1)*incy + 1
15614  do 10 i = 1,n
15615  sy(iy) = sy(iy) + sa*sx(ix)
15616  ix = ix + incx
15617  iy = iy + incy
15618  10 continue
15619  return
15620 c
15621 c code for both increments equal to 1
15622 c
15623 c
15624 c clean-up loop
15625 c
15626  20 m = mod(n,4)
15627  if( m .eq. 0 ) go to 40
15628  do 30 i = 1,m
15629  sy(i) = sy(i) + sa*sx(i)
15630  30 continue
15631  if( n .lt. 4 ) return
15632  40 mp1 = m + 1
15633  do 50 i = mp1,n,4
15634  sy(i) = sy(i) + sa*sx(i)
15635  sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
15636  sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
15637  sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
15638  50 continue
15639  return
15640  end
15641  real function scasum(n,cx,incx)
15642 c
15643 c takes the sum of the absolute values of a complex vector and
15644 c returns a single precision result.
15645 c jack dongarra, linpack, 3/11/78.
15646 c modified 3/93 to return if incx .le. 0.
15647 c modified 12/3/93, array(1) declarations changed to array(*)
15648 c
15649  complex cx(*)
15650  real stemp
15651  integer i,incx,n,nincx
15652 c
15653  scasum = 0.0e0
15654  stemp = 0.0e0
15655  if( n.le.0 .or. incx.le.0 )return
15656  if(incx.eq.1)go to 20
15657 c
15658 c code for increment not equal to 1
15659 c
15660  nincx = n*incx
15661  do 10 i = 1,nincx,incx
15662  stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
15663  10 continue
15664  scasum = stemp
15665  return
15666 c
15667 c code for increment equal to 1
15668 c
15669  20 do 30 i = 1,n
15670  stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
15671  30 continue
15672  scasum = stemp
15673  return
15674  end
15675  REAL FUNCTION scnrm2( N, X, INCX )
15676 * .. Scalar Arguments ..
15677  INTEGER INCX, N
15678 * .. Array Arguments ..
15679  COMPLEX X( * )
15680 * ..
15681 *
15682 * SCNRM2 returns the euclidean norm of a vector via the function
15683 * name, so that
15684 *
15685 * SCNRM2 := sqrt( conjg( x' )*x )
15686 *
15687 *
15688 *
15689 * -- This version written on 25-October-1982.
15690 * Modified on 14-October-1993 to inline the call to CLASSQ.
15691 * Sven Hammarling, Nag Ltd.
15692 *
15693 *
15694 * .. Parameters ..
15695  REAL ONE , ZERO
15696  parameter( one = 1.0e+0, zero = 0.0e+0 )
15697 * .. Local Scalars ..
15698  INTEGER IX
15699  REAL NORM, SCALE, SSQ, TEMP
15700 * .. Intrinsic Functions ..
15701  INTRINSIC abs, aimag, REAL, SQRT
15702 * ..
15703 * .. Executable Statements ..
15704  IF( n.LT.1 .OR. incx.LT.1 )THEN
15705  norm = zero
15706  ELSE
15707  scale = zero
15708  ssq = one
15709 * The following loop is equivalent to this call to the LAPACK
15710 * auxiliary routine:
15711 * CALL CLASSQ( N, X, INCX, SCALE, SSQ )
15712 *
15713  DO 10, ix = 1, 1 + ( n - 1 )*incx, incx
15714  IF( REAL( X( IX ) ).NE.zero )then
15715  temp = abs( REAL( X( IX ) ) )
15716  IF( scale.LT.temp )THEN
15717  ssq = one + ssq*( scale/temp )**2
15718  scale = temp
15719  ELSE
15720  ssq = ssq + ( temp/scale )**2
15721  END IF
15722  END IF
15723  IF( aimag( x( ix ) ).NE.zero )THEN
15724  temp = abs( aimag( x( ix ) ) )
15725  IF( scale.LT.temp )THEN
15726  ssq = one + ssq*( scale/temp )**2
15727  scale = temp
15728  ELSE
15729  ssq = ssq + ( temp/scale )**2
15730  END IF
15731  END IF
15732  10 CONTINUE
15733  norm = scale * sqrt( ssq )
15734  END IF
15735 *
15736  scnrm2 = norm
15737  RETURN
15738 *
15739 * End of SCNRM2.
15740 *
15741  END
15742  subroutine scopy(n,sx,incx,sy,incy)
15743 c
15744 c copies a vector, x, to a vector, y.
15745 c uses unrolled loops for increments equal to 1.
15746 c jack dongarra, linpack, 3/11/78.
15747 c modified 12/3/93, array(1) declarations changed to array(*)
15748 c
15749  real sx(*),sy(*)
15750  integer i,incx,incy,ix,iy,m,mp1,n
15751 c
15752  if(n.le.0)return
15753  if(incx.eq.1.and.incy.eq.1)go to 20
15754 c
15755 c code for unequal increments or equal increments
15756 c not equal to 1
15757 c
15758  ix = 1
15759  iy = 1
15760  if(incx.lt.0)ix = (-n+1)*incx + 1
15761  if(incy.lt.0)iy = (-n+1)*incy + 1
15762  do 10 i = 1,n
15763  sy(iy) = sx(ix)
15764  ix = ix + incx
15765  iy = iy + incy
15766  10 continue
15767  return
15768 c
15769 c code for both increments equal to 1
15770 c
15771 c
15772 c clean-up loop
15773 c
15774  20 m = mod(n,7)
15775  if( m .eq. 0 ) go to 40
15776  do 30 i = 1,m
15777  sy(i) = sx(i)
15778  30 continue
15779  if( n .lt. 7 ) return
15780  40 mp1 = m + 1
15781  do 50 i = mp1,n,7
15782  sy(i) = sx(i)
15783  sy(i + 1) = sx(i + 1)
15784  sy(i + 2) = sx(i + 2)
15785  sy(i + 3) = sx(i + 3)
15786  sy(i + 4) = sx(i + 4)
15787  sy(i + 5) = sx(i + 5)
15788  sy(i + 6) = sx(i + 6)
15789  50 continue
15790  return
15791  end
15792  real function sdot(n,sx,incx,sy,incy)
15793 c
15794 c forms the dot product of two vectors.
15795 c uses unrolled loops for increments equal to one.
15796 c jack dongarra, linpack, 3/11/78.
15797 c modified 12/3/93, array(1) declarations changed to array(*)
15798 c
15799  real sx(*),sy(*),stemp
15800  integer i,incx,incy,ix,iy,m,mp1,n
15801 c
15802  stemp = 0.0e0
15803  sdot = 0.0e0
15804  if(n.le.0)return
15805  if(incx.eq.1.and.incy.eq.1)go to 20
15806 c
15807 c code for unequal increments or equal increments
15808 c not equal to 1
15809 c
15810  ix = 1
15811  iy = 1
15812  if(incx.lt.0)ix = (-n+1)*incx + 1
15813  if(incy.lt.0)iy = (-n+1)*incy + 1
15814  do 10 i = 1,n
15815  stemp = stemp + sx(ix)*sy(iy)
15816  ix = ix + incx
15817  iy = iy + incy
15818  10 continue
15819  sdot = stemp
15820  return
15821 c
15822 c code for both increments equal to 1
15823 c
15824 c
15825 c clean-up loop
15826 c
15827  20 m = mod(n,5)
15828  if( m .eq. 0 ) go to 40
15829  do 30 i = 1,m
15830  stemp = stemp + sx(i)*sy(i)
15831  30 continue
15832  if( n .lt. 5 ) go to 60
15833  40 mp1 = m + 1
15834  do 50 i = mp1,n,5
15835  stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
15836  * sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
15837  50 continue
15838  60 sdot = stemp
15839  return
15840  end
15841 *DECK SDSDOT
15842  REAL FUNCTION sdsdot (N, SB, SX, INCX, SY, INCY)
15843 C***BEGIN PROLOGUE SDSDOT
15844 C***PURPOSE Compute the inner product of two vectors with extended
15845 C precision accumulation.
15846 C***LIBRARY SLATEC (BLAS)
15847 C***CATEGORY D1A4
15848 C***TYPE SINGLE PRECISION (SDSDOT-S, CDCDOT-C)
15849 C***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
15850 C***AUTHOR Lawson, C. L., (JPL)
15851 C Hanson, R. J., (SNLA)
15852 C Kincaid, D. R., (U. of Texas)
15853 C Krogh, F. T., (JPL)
15854 C***DESCRIPTION
15855 C
15856 C B L A S Subprogram
15857 C Description of Parameters
15858 C
15859 C --Input--
15860 C N number of elements in input vector(s)
15861 C SB single precision scalar to be added to inner product
15862 C SX single precision vector with N elements
15863 C INCX storage spacing between elements of SX
15864 C SY single precision vector with N elements
15865 C INCY storage spacing between elements of SY
15866 C
15867 C --Output--
15868 C SDSDOT single precision dot product (SB if N .LE. 0)
15869 C
15870 C Returns S.P. result with dot product accumulated in D.P.
15871 C SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
15872 C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
15873 C defined in a similar way using INCY.
15874 C
15875 C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
15876 C Krogh, Basic linear algebra subprograms for Fortran
15877 C usage, Algorithm No. 539, Transactions on Mathematical
15878 C Software 5, 3 (September 1979), pp. 308-323.
15879 C***ROUTINES CALLED (NONE)
15880 C***REVISION HISTORY (YYMMDD)
15881 C 791001 DATE WRITTEN
15882 C 890531 Changed all specific intrinsics to generic. (WRB)
15883 C 890831 Modified array declarations. (WRB)
15884 C 890831 REVISION DATE from Version 3.2
15885 C 891214 Prologue converted to Version 4.0 format. (BAB)
15886 C 920310 Corrected definition of LX in DESCRIPTION. (WRB)
15887 C 920501 Reformatted the REFERENCES section. (WRB)
15888 C***END PROLOGUE SDSDOT
15889  REAL SX(*), SY(*), SB
15890  DOUBLE PRECISION DSDOT
15891 C***FIRST EXECUTABLE STATEMENT SDSDOT
15892  dsdot = sb
15893  IF (n .LE. 0) GO TO 30
15894  IF (incx.EQ.incy .AND. incx.GT.0) GO TO 40
15895 C
15896 C Code for unequal or nonpositive increments.
15897 C
15898  kx = 1
15899  ky = 1
15900  IF (incx .LT. 0) kx = 1+(1-n)*incx
15901  IF (incy .LT. 0) ky = 1+(1-n)*incy
15902  DO 10 i = 1,n
15903  dsdot = dsdot + dble(sx(kx))*dble(sy(ky))
15904  kx = kx + incx
15905  ky = ky + incy
15906  10 CONTINUE
15907  30 sdsdot = dsdot
15908  RETURN
15909 C
15910 C Code for equal and positive increments.
15911 C
15912  40 ns = n*incx
15913  DO 50 i = 1,ns,incx
15914  dsdot = dsdot + dble(sx(i))*dble(sy(i))
15915  50 CONTINUE
15916  sdsdot = dsdot
15917  RETURN
15918  END
15919  SUBROUTINE sgbmv ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
15920  $ beta, y, incy )
15921 * .. Scalar Arguments ..
15922  REAL ALPHA, BETA
15923  INTEGER INCX, INCY, KL, KU, LDA, M, N
15924  CHARACTER*1 TRANS
15925 * .. Array Arguments ..
15926  REAL A( lda, * ), X( * ), Y( * )
15927 * ..
15928 *
15929 * Purpose
15930 * =======
15931 *
15932 * SGBMV performs one of the matrix-vector operations
15933 *
15934 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
15935 *
15936 * where alpha and beta are scalars, x and y are vectors and A is an
15937 * m by n band matrix, with kl sub-diagonals and ku super-diagonals.
15938 *
15939 * Parameters
15940 * ==========
15941 *
15942 * TRANS - CHARACTER*1.
15943 * On entry, TRANS specifies the operation to be performed as
15944 * follows:
15945 *
15946 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
15947 *
15948 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
15949 *
15950 * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
15951 *
15952 * Unchanged on exit.
15953 *
15954 * M - INTEGER.
15955 * On entry, M specifies the number of rows of the matrix A.
15956 * M must be at least zero.
15957 * Unchanged on exit.
15958 *
15959 * N - INTEGER.
15960 * On entry, N specifies the number of columns of the matrix A.
15961 * N must be at least zero.
15962 * Unchanged on exit.
15963 *
15964 * KL - INTEGER.
15965 * On entry, KL specifies the number of sub-diagonals of the
15966 * matrix A. KL must satisfy 0 .le. KL.
15967 * Unchanged on exit.
15968 *
15969 * KU - INTEGER.
15970 * On entry, KU specifies the number of super-diagonals of the
15971 * matrix A. KU must satisfy 0 .le. KU.
15972 * Unchanged on exit.
15973 *
15974 * ALPHA - REAL .
15975 * On entry, ALPHA specifies the scalar alpha.
15976 * Unchanged on exit.
15977 *
15978 * A - REAL array of DIMENSION ( LDA, n ).
15979 * Before entry, the leading ( kl + ku + 1 ) by n part of the
15980 * array A must contain the matrix of coefficients, supplied
15981 * column by column, with the leading diagonal of the matrix in
15982 * row ( ku + 1 ) of the array, the first super-diagonal
15983 * starting at position 2 in row ku, the first sub-diagonal
15984 * starting at position 1 in row ( ku + 2 ), and so on.
15985 * Elements in the array A that do not correspond to elements
15986 * in the band matrix (such as the top left ku by ku triangle)
15987 * are not referenced.
15988 * The following program segment will transfer a band matrix
15989 * from conventional full matrix storage to band storage:
15990 *
15991 * DO 20, J = 1, N
15992 * K = KU + 1 - J
15993 * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
15994 * A( K + I, J ) = matrix( I, J )
15995 * 10 CONTINUE
15996 * 20 CONTINUE
15997 *
15998 * Unchanged on exit.
15999 *
16000 * LDA - INTEGER.
16001 * On entry, LDA specifies the first dimension of A as declared
16002 * in the calling (sub) program. LDA must be at least
16003 * ( kl + ku + 1 ).
16004 * Unchanged on exit.
16005 *
16006 * X - REAL array of DIMENSION at least
16007 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
16008 * and at least
16009 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
16010 * Before entry, the incremented array X must contain the
16011 * vector x.
16012 * Unchanged on exit.
16013 *
16014 * INCX - INTEGER.
16015 * On entry, INCX specifies the increment for the elements of
16016 * X. INCX must not be zero.
16017 * Unchanged on exit.
16018 *
16019 * BETA - REAL .
16020 * On entry, BETA specifies the scalar beta. When BETA is
16021 * supplied as zero then Y need not be set on input.
16022 * Unchanged on exit.
16023 *
16024 * Y - REAL array of DIMENSION at least
16025 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
16026 * and at least
16027 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
16028 * Before entry, the incremented array Y must contain the
16029 * vector y. On exit, Y is overwritten by the updated vector y.
16030 *
16031 * INCY - INTEGER.
16032 * On entry, INCY specifies the increment for the elements of
16033 * Y. INCY must not be zero.
16034 * Unchanged on exit.
16035 *
16036 *
16037 * Level 2 Blas routine.
16038 *
16039 * -- Written on 22-October-1986.
16040 * Jack Dongarra, Argonne National Lab.
16041 * Jeremy Du Croz, Nag Central Office.
16042 * Sven Hammarling, Nag Central Office.
16043 * Richard Hanson, Sandia National Labs.
16044 *
16045 * .. Parameters ..
16046  REAL ONE , ZERO
16047  parameter( one = 1.0e+0, zero = 0.0e+0 )
16048 * .. Local Scalars ..
16049  REAL TEMP
16050  INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
16051  $ lenx, leny
16052 * .. External Functions ..
16053  LOGICAL LSAME
16054  EXTERNAL lsame
16055 * .. External Subroutines ..
16056  EXTERNAL xerbla
16057 * .. Intrinsic Functions ..
16058  INTRINSIC max, min
16059 * ..
16060 * .. Executable Statements ..
16061 *
16062 * Test the input parameters.
16063 *
16064  info = 0
16065  IF ( .NOT.lsame( trans, 'N' ).AND.
16066  $ .NOT.lsame( trans, 'T' ).AND.
16067  $ .NOT.lsame( trans, 'C' ) )THEN
16068  info = 1
16069  ELSE IF( m.LT.0 )THEN
16070  info = 2
16071  ELSE IF( n.LT.0 )THEN
16072  info = 3
16073  ELSE IF( kl.LT.0 )THEN
16074  info = 4
16075  ELSE IF( ku.LT.0 )THEN
16076  info = 5
16077  ELSE IF( lda.LT.( kl + ku + 1 ) )THEN
16078  info = 8
16079  ELSE IF( incx.EQ.0 )THEN
16080  info = 10
16081  ELSE IF( incy.EQ.0 )THEN
16082  info = 13
16083  END IF
16084  IF( info.NE.0 )THEN
16085  CALL xerbla( 'SGBMV ', info )
16086  RETURN
16087  END IF
16088 *
16089 * Quick return if possible.
16090 *
16091  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
16092  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
16093  $ RETURN
16094 *
16095 * Set LENX and LENY, the lengths of the vectors x and y, and set
16096 * up the start points in X and Y.
16097 *
16098  IF( lsame( trans, 'N' ) )THEN
16099  lenx = n
16100  leny = m
16101  ELSE
16102  lenx = m
16103  leny = n
16104  END IF
16105  IF( incx.GT.0 )THEN
16106  kx = 1
16107  ELSE
16108  kx = 1 - ( lenx - 1 )*incx
16109  END IF
16110  IF( incy.GT.0 )THEN
16111  ky = 1
16112  ELSE
16113  ky = 1 - ( leny - 1 )*incy
16114  END IF
16115 *
16116 * Start the operations. In this version the elements of A are
16117 * accessed sequentially with one pass through the band part of A.
16118 *
16119 * First form y := beta*y.
16120 *
16121  IF( beta.NE.one )THEN
16122  IF( incy.EQ.1 )THEN
16123  IF( beta.EQ.zero )THEN
16124  DO 10, i = 1, leny
16125  y( i ) = zero
16126  10 CONTINUE
16127  ELSE
16128  DO 20, i = 1, leny
16129  y( i ) = beta*y( i )
16130  20 CONTINUE
16131  END IF
16132  ELSE
16133  iy = ky
16134  IF( beta.EQ.zero )THEN
16135  DO 30, i = 1, leny
16136  y( iy ) = zero
16137  iy = iy + incy
16138  30 CONTINUE
16139  ELSE
16140  DO 40, i = 1, leny
16141  y( iy ) = beta*y( iy )
16142  iy = iy + incy
16143  40 CONTINUE
16144  END IF
16145  END IF
16146  END IF
16147  IF( alpha.EQ.zero )
16148  $ RETURN
16149  kup1 = ku + 1
16150  IF( lsame( trans, 'N' ) )THEN
16151 *
16152 * Form y := alpha*A*x + y.
16153 *
16154  jx = kx
16155  IF( incy.EQ.1 )THEN
16156  DO 60, j = 1, n
16157  IF( x( jx ).NE.zero )THEN
16158  temp = alpha*x( jx )
16159  k = kup1 - j
16160  DO 50, i = max( 1, j - ku ), min( m, j + kl )
16161  y( i ) = y( i ) + temp*a( k + i, j )
16162  50 CONTINUE
16163  END IF
16164  jx = jx + incx
16165  60 CONTINUE
16166  ELSE
16167  DO 80, j = 1, n
16168  IF( x( jx ).NE.zero )THEN
16169  temp = alpha*x( jx )
16170  iy = ky
16171  k = kup1 - j
16172  DO 70, i = max( 1, j - ku ), min( m, j + kl )
16173  y( iy ) = y( iy ) + temp*a( k + i, j )
16174  iy = iy + incy
16175  70 CONTINUE
16176  END IF
16177  jx = jx + incx
16178  IF( j.GT.ku )
16179  $ ky = ky + incy
16180  80 CONTINUE
16181  END IF
16182  ELSE
16183 *
16184 * Form y := alpha*A'*x + y.
16185 *
16186  jy = ky
16187  IF( incx.EQ.1 )THEN
16188  DO 100, j = 1, n
16189  temp = zero
16190  k = kup1 - j
16191  DO 90, i = max( 1, j - ku ), min( m, j + kl )
16192  temp = temp + a( k + i, j )*x( i )
16193  90 CONTINUE
16194  y( jy ) = y( jy ) + alpha*temp
16195  jy = jy + incy
16196  100 CONTINUE
16197  ELSE
16198  DO 120, j = 1, n
16199  temp = zero
16200  ix = kx
16201  k = kup1 - j
16202  DO 110, i = max( 1, j - ku ), min( m, j + kl )
16203  temp = temp + a( k + i, j )*x( ix )
16204  ix = ix + incx
16205  110 CONTINUE
16206  y( jy ) = y( jy ) + alpha*temp
16207  jy = jy + incy
16208  IF( j.GT.ku )
16209  $ kx = kx + incx
16210  120 CONTINUE
16211  END IF
16212  END IF
16213 *
16214  RETURN
16215 *
16216 * End of SGBMV .
16217 *
16218  END
16219  SUBROUTINE sgemm ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
16220  $ beta, c, ldc )
16221 * .. Scalar Arguments ..
16222  CHARACTER*1 TRANSA, TRANSB
16223  INTEGER M, N, K, LDA, LDB, LDC
16224  REAL ALPHA, BETA
16225 * .. Array Arguments ..
16226  REAL A( lda, * ), B( ldb, * ), C( ldc, * )
16227 * ..
16228 *
16229 * Purpose
16230 * =======
16231 *
16232 * SGEMM performs one of the matrix-matrix operations
16233 *
16234 * C := alpha*op( A )*op( B ) + beta*C,
16235 *
16236 * where op( X ) is one of
16237 *
16238 * op( X ) = X or op( X ) = X',
16239 *
16240 * alpha and beta are scalars, and A, B and C are matrices, with op( A )
16241 * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
16242 *
16243 * Parameters
16244 * ==========
16245 *
16246 * TRANSA - CHARACTER*1.
16247 * On entry, TRANSA specifies the form of op( A ) to be used in
16248 * the matrix multiplication as follows:
16249 *
16250 * TRANSA = 'N' or 'n', op( A ) = A.
16251 *
16252 * TRANSA = 'T' or 't', op( A ) = A'.
16253 *
16254 * TRANSA = 'C' or 'c', op( A ) = A'.
16255 *
16256 * Unchanged on exit.
16257 *
16258 * TRANSB - CHARACTER*1.
16259 * On entry, TRANSB specifies the form of op( B ) to be used in
16260 * the matrix multiplication as follows:
16261 *
16262 * TRANSB = 'N' or 'n', op( B ) = B.
16263 *
16264 * TRANSB = 'T' or 't', op( B ) = B'.
16265 *
16266 * TRANSB = 'C' or 'c', op( B ) = B'.
16267 *
16268 * Unchanged on exit.
16269 *
16270 * M - INTEGER.
16271 * On entry, M specifies the number of rows of the matrix
16272 * op( A ) and of the matrix C. M must be at least zero.
16273 * Unchanged on exit.
16274 *
16275 * N - INTEGER.
16276 * On entry, N specifies the number of columns of the matrix
16277 * op( B ) and the number of columns of the matrix C. N must be
16278 * at least zero.
16279 * Unchanged on exit.
16280 *
16281 * K - INTEGER.
16282 * On entry, K specifies the number of columns of the matrix
16283 * op( A ) and the number of rows of the matrix op( B ). K must
16284 * be at least zero.
16285 * Unchanged on exit.
16286 *
16287 * ALPHA - REAL .
16288 * On entry, ALPHA specifies the scalar alpha.
16289 * Unchanged on exit.
16290 *
16291 * A - REAL array of DIMENSION ( LDA, ka ), where ka is
16292 * k when TRANSA = 'N' or 'n', and is m otherwise.
16293 * Before entry with TRANSA = 'N' or 'n', the leading m by k
16294 * part of the array A must contain the matrix A, otherwise
16295 * the leading k by m part of the array A must contain the
16296 * matrix A.
16297 * Unchanged on exit.
16298 *
16299 * LDA - INTEGER.
16300 * On entry, LDA specifies the first dimension of A as declared
16301 * in the calling (sub) program. When TRANSA = 'N' or 'n' then
16302 * LDA must be at least max( 1, m ), otherwise LDA must be at
16303 * least max( 1, k ).
16304 * Unchanged on exit.
16305 *
16306 * B - REAL array of DIMENSION ( LDB, kb ), where kb is
16307 * n when TRANSB = 'N' or 'n', and is k otherwise.
16308 * Before entry with TRANSB = 'N' or 'n', the leading k by n
16309 * part of the array B must contain the matrix B, otherwise
16310 * the leading n by k part of the array B must contain the
16311 * matrix B.
16312 * Unchanged on exit.
16313 *
16314 * LDB - INTEGER.
16315 * On entry, LDB specifies the first dimension of B as declared
16316 * in the calling (sub) program. When TRANSB = 'N' or 'n' then
16317 * LDB must be at least max( 1, k ), otherwise LDB must be at
16318 * least max( 1, n ).
16319 * Unchanged on exit.
16320 *
16321 * BETA - REAL .
16322 * On entry, BETA specifies the scalar beta. When BETA is
16323 * supplied as zero then C need not be set on input.
16324 * Unchanged on exit.
16325 *
16326 * C - REAL array of DIMENSION ( LDC, n ).
16327 * Before entry, the leading m by n part of the array C must
16328 * contain the matrix C, except when beta is zero, in which
16329 * case C need not be set on entry.
16330 * On exit, the array C is overwritten by the m by n matrix
16331 * ( alpha*op( A )*op( B ) + beta*C ).
16332 *
16333 * LDC - INTEGER.
16334 * On entry, LDC specifies the first dimension of C as declared
16335 * in the calling (sub) program. LDC must be at least
16336 * max( 1, m ).
16337 * Unchanged on exit.
16338 *
16339 *
16340 * Level 3 Blas routine.
16341 *
16342 * -- Written on 8-February-1989.
16343 * Jack Dongarra, Argonne National Laboratory.
16344 * Iain Duff, AERE Harwell.
16345 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
16346 * Sven Hammarling, Numerical Algorithms Group Ltd.
16347 *
16348 *
16349 * .. External Functions ..
16350  LOGICAL LSAME
16351  EXTERNAL lsame
16352 * .. External Subroutines ..
16353  EXTERNAL xerbla
16354 * .. Intrinsic Functions ..
16355  INTRINSIC max
16356 * .. Local Scalars ..
16357  LOGICAL NOTA, NOTB
16358  INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
16359  REAL TEMP
16360 * .. Parameters ..
16361  REAL ONE , ZERO
16362  parameter( one = 1.0e+0, zero = 0.0e+0 )
16363 * ..
16364 * .. Executable Statements ..
16365 *
16366 * Set NOTA and NOTB as true if A and B respectively are not
16367 * transposed and set NROWA, NCOLA and NROWB as the number of rows
16368 * and columns of A and the number of rows of B respectively.
16369 *
16370  nota = lsame( transa, 'N' )
16371  notb = lsame( transb, 'N' )
16372  IF( nota )THEN
16373  nrowa = m
16374  ncola = k
16375  ELSE
16376  nrowa = k
16377  ncola = m
16378  END IF
16379  IF( notb )THEN
16380  nrowb = k
16381  ELSE
16382  nrowb = n
16383  END IF
16384 *
16385 * Test the input parameters.
16386 *
16387  info = 0
16388  IF( ( .NOT.nota ).AND.
16389  $ ( .NOT.lsame( transa, 'C' ) ).AND.
16390  $ ( .NOT.lsame( transa, 'T' ) ) )THEN
16391  info = 1
16392  ELSE IF( ( .NOT.notb ).AND.
16393  $ ( .NOT.lsame( transb, 'C' ) ).AND.
16394  $ ( .NOT.lsame( transb, 'T' ) ) )THEN
16395  info = 2
16396  ELSE IF( m .LT.0 )THEN
16397  info = 3
16398  ELSE IF( n .LT.0 )THEN
16399  info = 4
16400  ELSE IF( k .LT.0 )THEN
16401  info = 5
16402  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
16403  info = 8
16404  ELSE IF( ldb.LT.max( 1, nrowb ) )THEN
16405  info = 10
16406  ELSE IF( ldc.LT.max( 1, m ) )THEN
16407  info = 13
16408  END IF
16409  IF( info.NE.0 )THEN
16410  CALL xerbla( 'SGEMM ', info )
16411  RETURN
16412  END IF
16413 *
16414 * Quick return if possible.
16415 *
16416  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
16417  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
16418  $ RETURN
16419 *
16420 * And if alpha.eq.zero.
16421 *
16422  IF( alpha.EQ.zero )THEN
16423  IF( beta.EQ.zero )THEN
16424  DO 20, j = 1, n
16425  DO 10, i = 1, m
16426  c( i, j ) = zero
16427  10 CONTINUE
16428  20 CONTINUE
16429  ELSE
16430  DO 40, j = 1, n
16431  DO 30, i = 1, m
16432  c( i, j ) = beta*c( i, j )
16433  30 CONTINUE
16434  40 CONTINUE
16435  END IF
16436  RETURN
16437  END IF
16438 *
16439 * Start the operations.
16440 *
16441  IF( notb )THEN
16442  IF( nota )THEN
16443 *
16444 * Form C := alpha*A*B + beta*C.
16445 *
16446  DO 90, j = 1, n
16447  IF( beta.EQ.zero )THEN
16448  DO 50, i = 1, m
16449  c( i, j ) = zero
16450  50 CONTINUE
16451  ELSE IF( beta.NE.one )THEN
16452  DO 60, i = 1, m
16453  c( i, j ) = beta*c( i, j )
16454  60 CONTINUE
16455  END IF
16456  DO 80, l = 1, k
16457  IF( b( l, j ).NE.zero )THEN
16458  temp = alpha*b( l, j )
16459  DO 70, i = 1, m
16460  c( i, j ) = c( i, j ) + temp*a( i, l )
16461  70 CONTINUE
16462  END IF
16463  80 CONTINUE
16464  90 CONTINUE
16465  ELSE
16466 *
16467 * Form C := alpha*A'*B + beta*C
16468 *
16469  DO 120, j = 1, n
16470  DO 110, i = 1, m
16471  temp = zero
16472  DO 100, l = 1, k
16473  temp = temp + a( l, i )*b( l, j )
16474  100 CONTINUE
16475  IF( beta.EQ.zero )THEN
16476  c( i, j ) = alpha*temp
16477  ELSE
16478  c( i, j ) = alpha*temp + beta*c( i, j )
16479  END IF
16480  110 CONTINUE
16481  120 CONTINUE
16482  END IF
16483  ELSE
16484  IF( nota )THEN
16485 *
16486 * Form C := alpha*A*B' + beta*C
16487 *
16488  DO 170, j = 1, n
16489  IF( beta.EQ.zero )THEN
16490  DO 130, i = 1, m
16491  c( i, j ) = zero
16492  130 CONTINUE
16493  ELSE IF( beta.NE.one )THEN
16494  DO 140, i = 1, m
16495  c( i, j ) = beta*c( i, j )
16496  140 CONTINUE
16497  END IF
16498  DO 160, l = 1, k
16499  IF( b( j, l ).NE.zero )THEN
16500  temp = alpha*b( j, l )
16501  DO 150, i = 1, m
16502  c( i, j ) = c( i, j ) + temp*a( i, l )
16503  150 CONTINUE
16504  END IF
16505  160 CONTINUE
16506  170 CONTINUE
16507  ELSE
16508 *
16509 * Form C := alpha*A'*B' + beta*C
16510 *
16511  DO 200, j = 1, n
16512  DO 190, i = 1, m
16513  temp = zero
16514  DO 180, l = 1, k
16515  temp = temp + a( l, i )*b( j, l )
16516  180 CONTINUE
16517  IF( beta.EQ.zero )THEN
16518  c( i, j ) = alpha*temp
16519  ELSE
16520  c( i, j ) = alpha*temp + beta*c( i, j )
16521  END IF
16522  190 CONTINUE
16523  200 CONTINUE
16524  END IF
16525  END IF
16526 *
16527  RETURN
16528 *
16529 * End of SGEMM .
16530 *
16531  END
16532  SUBROUTINE sgemv ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
16533  $ beta, y, incy )
16534 * .. Scalar Arguments ..
16535  REAL ALPHA, BETA
16536  INTEGER INCX, INCY, LDA, M, N
16537  CHARACTER*1 TRANS
16538 * .. Array Arguments ..
16539  REAL A( lda, * ), X( * ), Y( * )
16540 * ..
16541 *
16542 * Purpose
16543 * =======
16544 *
16545 * SGEMV performs one of the matrix-vector operations
16546 *
16547 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
16548 *
16549 * where alpha and beta are scalars, x and y are vectors and A is an
16550 * m by n matrix.
16551 *
16552 * Parameters
16553 * ==========
16554 *
16555 * TRANS - CHARACTER*1.
16556 * On entry, TRANS specifies the operation to be performed as
16557 * follows:
16558 *
16559 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
16560 *
16561 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
16562 *
16563 * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
16564 *
16565 * Unchanged on exit.
16566 *
16567 * M - INTEGER.
16568 * On entry, M specifies the number of rows of the matrix A.
16569 * M must be at least zero.
16570 * Unchanged on exit.
16571 *
16572 * N - INTEGER.
16573 * On entry, N specifies the number of columns of the matrix A.
16574 * N must be at least zero.
16575 * Unchanged on exit.
16576 *
16577 * ALPHA - REAL .
16578 * On entry, ALPHA specifies the scalar alpha.
16579 * Unchanged on exit.
16580 *
16581 * A - REAL array of DIMENSION ( LDA, n ).
16582 * Before entry, the leading m by n part of the array A must
16583 * contain the matrix of coefficients.
16584 * Unchanged on exit.
16585 *
16586 * LDA - INTEGER.
16587 * On entry, LDA specifies the first dimension of A as declared
16588 * in the calling (sub) program. LDA must be at least
16589 * max( 1, m ).
16590 * Unchanged on exit.
16591 *
16592 * X - REAL array of DIMENSION at least
16593 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
16594 * and at least
16595 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
16596 * Before entry, the incremented array X must contain the
16597 * vector x.
16598 * Unchanged on exit.
16599 *
16600 * INCX - INTEGER.
16601 * On entry, INCX specifies the increment for the elements of
16602 * X. INCX must not be zero.
16603 * Unchanged on exit.
16604 *
16605 * BETA - REAL .
16606 * On entry, BETA specifies the scalar beta. When BETA is
16607 * supplied as zero then Y need not be set on input.
16608 * Unchanged on exit.
16609 *
16610 * Y - REAL array of DIMENSION at least
16611 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
16612 * and at least
16613 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
16614 * Before entry with BETA non-zero, the incremented array Y
16615 * must contain the vector y. On exit, Y is overwritten by the
16616 * updated vector y.
16617 *
16618 * INCY - INTEGER.
16619 * On entry, INCY specifies the increment for the elements of
16620 * Y. INCY must not be zero.
16621 * Unchanged on exit.
16622 *
16623 *
16624 * Level 2 Blas routine.
16625 *
16626 * -- Written on 22-October-1986.
16627 * Jack Dongarra, Argonne National Lab.
16628 * Jeremy Du Croz, Nag Central Office.
16629 * Sven Hammarling, Nag Central Office.
16630 * Richard Hanson, Sandia National Labs.
16631 *
16632 *
16633 * .. Parameters ..
16634  REAL ONE , ZERO
16635  parameter( one = 1.0e+0, zero = 0.0e+0 )
16636 * .. Local Scalars ..
16637  REAL TEMP
16638  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
16639 * .. External Functions ..
16640  LOGICAL LSAME
16641  EXTERNAL lsame
16642 * .. External Subroutines ..
16643  EXTERNAL xerbla
16644 * .. Intrinsic Functions ..
16645  INTRINSIC max
16646 * ..
16647 * .. Executable Statements ..
16648 *
16649 * Test the input parameters.
16650 *
16651  info = 0
16652  IF ( .NOT.lsame( trans, 'N' ).AND.
16653  $ .NOT.lsame( trans, 'T' ).AND.
16654  $ .NOT.lsame( trans, 'C' ) )THEN
16655  info = 1
16656  ELSE IF( m.LT.0 )THEN
16657  info = 2
16658  ELSE IF( n.LT.0 )THEN
16659  info = 3
16660  ELSE IF( lda.LT.max( 1, m ) )THEN
16661  info = 6
16662  ELSE IF( incx.EQ.0 )THEN
16663  info = 8
16664  ELSE IF( incy.EQ.0 )THEN
16665  info = 11
16666  END IF
16667  IF( info.NE.0 )THEN
16668  CALL xerbla( 'SGEMV ', info )
16669  RETURN
16670  END IF
16671 *
16672 * Quick return if possible.
16673 *
16674  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
16675  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
16676  $ RETURN
16677 *
16678 * Set LENX and LENY, the lengths of the vectors x and y, and set
16679 * up the start points in X and Y.
16680 *
16681  IF( lsame( trans, 'N' ) )THEN
16682  lenx = n
16683  leny = m
16684  ELSE
16685  lenx = m
16686  leny = n
16687  END IF
16688  IF( incx.GT.0 )THEN
16689  kx = 1
16690  ELSE
16691  kx = 1 - ( lenx - 1 )*incx
16692  END IF
16693  IF( incy.GT.0 )THEN
16694  ky = 1
16695  ELSE
16696  ky = 1 - ( leny - 1 )*incy
16697  END IF
16698 *
16699 * Start the operations. In this version the elements of A are
16700 * accessed sequentially with one pass through A.
16701 *
16702 * First form y := beta*y.
16703 *
16704  IF( beta.NE.one )THEN
16705  IF( incy.EQ.1 )THEN
16706  IF( beta.EQ.zero )THEN
16707  DO 10, i = 1, leny
16708  y( i ) = zero
16709  10 CONTINUE
16710  ELSE
16711  DO 20, i = 1, leny
16712  y( i ) = beta*y( i )
16713  20 CONTINUE
16714  END IF
16715  ELSE
16716  iy = ky
16717  IF( beta.EQ.zero )THEN
16718  DO 30, i = 1, leny
16719  y( iy ) = zero
16720  iy = iy + incy
16721  30 CONTINUE
16722  ELSE
16723  DO 40, i = 1, leny
16724  y( iy ) = beta*y( iy )
16725  iy = iy + incy
16726  40 CONTINUE
16727  END IF
16728  END IF
16729  END IF
16730  IF( alpha.EQ.zero )
16731  $ RETURN
16732  IF( lsame( trans, 'N' ) )THEN
16733 *
16734 * Form y := alpha*A*x + y.
16735 *
16736  jx = kx
16737  IF( incy.EQ.1 )THEN
16738  DO 60, j = 1, n
16739  IF( x( jx ).NE.zero )THEN
16740  temp = alpha*x( jx )
16741  DO 50, i = 1, m
16742  y( i ) = y( i ) + temp*a( i, j )
16743  50 CONTINUE
16744  END IF
16745  jx = jx + incx
16746  60 CONTINUE
16747  ELSE
16748  DO 80, j = 1, n
16749  IF( x( jx ).NE.zero )THEN
16750  temp = alpha*x( jx )
16751  iy = ky
16752  DO 70, i = 1, m
16753  y( iy ) = y( iy ) + temp*a( i, j )
16754  iy = iy + incy
16755  70 CONTINUE
16756  END IF
16757  jx = jx + incx
16758  80 CONTINUE
16759  END IF
16760  ELSE
16761 *
16762 * Form y := alpha*A'*x + y.
16763 *
16764  jy = ky
16765  IF( incx.EQ.1 )THEN
16766  DO 100, j = 1, n
16767  temp = zero
16768  DO 90, i = 1, m
16769  temp = temp + a( i, j )*x( i )
16770  90 CONTINUE
16771  y( jy ) = y( jy ) + alpha*temp
16772  jy = jy + incy
16773  100 CONTINUE
16774  ELSE
16775  DO 120, j = 1, n
16776  temp = zero
16777  ix = kx
16778  DO 110, i = 1, m
16779  temp = temp + a( i, j )*x( ix )
16780  ix = ix + incx
16781  110 CONTINUE
16782  y( jy ) = y( jy ) + alpha*temp
16783  jy = jy + incy
16784  120 CONTINUE
16785  END IF
16786  END IF
16787 *
16788  RETURN
16789 *
16790 * End of SGEMV .
16791 *
16792  END
16793  SUBROUTINE sger ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
16794 * .. Scalar Arguments ..
16795  REAL ALPHA
16796  INTEGER INCX, INCY, LDA, M, N
16797 * .. Array Arguments ..
16798  REAL A( lda, * ), X( * ), Y( * )
16799 * ..
16800 *
16801 * Purpose
16802 * =======
16803 *
16804 * SGER performs the rank 1 operation
16805 *
16806 * A := alpha*x*y' + A,
16807 *
16808 * where alpha is a scalar, x is an m element vector, y is an n element
16809 * vector and A is an m by n matrix.
16810 *
16811 * Parameters
16812 * ==========
16813 *
16814 * M - INTEGER.
16815 * On entry, M specifies the number of rows of the matrix A.
16816 * M must be at least zero.
16817 * Unchanged on exit.
16818 *
16819 * N - INTEGER.
16820 * On entry, N specifies the number of columns of the matrix A.
16821 * N must be at least zero.
16822 * Unchanged on exit.
16823 *
16824 * ALPHA - REAL .
16825 * On entry, ALPHA specifies the scalar alpha.
16826 * Unchanged on exit.
16827 *
16828 * X - REAL array of dimension at least
16829 * ( 1 + ( m - 1 )*abs( INCX ) ).
16830 * Before entry, the incremented array X must contain the m
16831 * element vector x.
16832 * Unchanged on exit.
16833 *
16834 * INCX - INTEGER.
16835 * On entry, INCX specifies the increment for the elements of
16836 * X. INCX must not be zero.
16837 * Unchanged on exit.
16838 *
16839 * Y - REAL array of dimension at least
16840 * ( 1 + ( n - 1 )*abs( INCY ) ).
16841 * Before entry, the incremented array Y must contain the n
16842 * element vector y.
16843 * Unchanged on exit.
16844 *
16845 * INCY - INTEGER.
16846 * On entry, INCY specifies the increment for the elements of
16847 * Y. INCY must not be zero.
16848 * Unchanged on exit.
16849 *
16850 * A - REAL array of DIMENSION ( LDA, n ).
16851 * Before entry, the leading m by n part of the array A must
16852 * contain the matrix of coefficients. On exit, A is
16853 * overwritten by the updated matrix.
16854 *
16855 * LDA - INTEGER.
16856 * On entry, LDA specifies the first dimension of A as declared
16857 * in the calling (sub) program. LDA must be at least
16858 * max( 1, m ).
16859 * Unchanged on exit.
16860 *
16861 *
16862 * Level 2 Blas routine.
16863 *
16864 * -- Written on 22-October-1986.
16865 * Jack Dongarra, Argonne National Lab.
16866 * Jeremy Du Croz, Nag Central Office.
16867 * Sven Hammarling, Nag Central Office.
16868 * Richard Hanson, Sandia National Labs.
16869 *
16870 *
16871 * .. Parameters ..
16872  REAL ZERO
16873  parameter( zero = 0.0e+0 )
16874 * .. Local Scalars ..
16875  REAL TEMP
16876  INTEGER I, INFO, IX, J, JY, KX
16877 * .. External Subroutines ..
16878  EXTERNAL xerbla
16879 * .. Intrinsic Functions ..
16880  INTRINSIC max
16881 * ..
16882 * .. Executable Statements ..
16883 *
16884 * Test the input parameters.
16885 *
16886  info = 0
16887  IF ( m.LT.0 )THEN
16888  info = 1
16889  ELSE IF( n.LT.0 )THEN
16890  info = 2
16891  ELSE IF( incx.EQ.0 )THEN
16892  info = 5
16893  ELSE IF( incy.EQ.0 )THEN
16894  info = 7
16895  ELSE IF( lda.LT.max( 1, m ) )THEN
16896  info = 9
16897  END IF
16898  IF( info.NE.0 )THEN
16899  CALL xerbla( 'SGER ', info )
16900  RETURN
16901  END IF
16902 *
16903 * Quick return if possible.
16904 *
16905  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
16906  $ RETURN
16907 *
16908 * Start the operations. In this version the elements of A are
16909 * accessed sequentially with one pass through A.
16910 *
16911  IF( incy.GT.0 )THEN
16912  jy = 1
16913  ELSE
16914  jy = 1 - ( n - 1 )*incy
16915  END IF
16916  IF( incx.EQ.1 )THEN
16917  DO 20, j = 1, n
16918  IF( y( jy ).NE.zero )THEN
16919  temp = alpha*y( jy )
16920  DO 10, i = 1, m
16921  a( i, j ) = a( i, j ) + x( i )*temp
16922  10 CONTINUE
16923  END IF
16924  jy = jy + incy
16925  20 CONTINUE
16926  ELSE
16927  IF( incx.GT.0 )THEN
16928  kx = 1
16929  ELSE
16930  kx = 1 - ( m - 1 )*incx
16931  END IF
16932  DO 40, j = 1, n
16933  IF( y( jy ).NE.zero )THEN
16934  temp = alpha*y( jy )
16935  ix = kx
16936  DO 30, i = 1, m
16937  a( i, j ) = a( i, j ) + x( ix )*temp
16938  ix = ix + incx
16939  30 CONTINUE
16940  END IF
16941  jy = jy + incy
16942  40 CONTINUE
16943  END IF
16944 *
16945  RETURN
16946 *
16947 * End of SGER .
16948 *
16949  END
16950  REAL FUNCTION snrm2 ( N, X, INCX )
16951 * .. Scalar Arguments ..
16952  INTEGER INCX, N
16953 * .. Array Arguments ..
16954  REAL X( * )
16955 * ..
16956 *
16957 * SNRM2 returns the euclidean norm of a vector via the function
16958 * name, so that
16959 *
16960 * SNRM2 := sqrt( x'*x )
16961 *
16962 *
16963 *
16964 * -- This version written on 25-October-1982.
16965 * Modified on 14-October-1993 to inline the call to SLASSQ.
16966 * Sven Hammarling, Nag Ltd.
16967 *
16968 *
16969 * .. Parameters ..
16970  REAL ONE , ZERO
16971  parameter( one = 1.0e+0, zero = 0.0e+0 )
16972 * .. Local Scalars ..
16973  INTEGER IX
16974  REAL ABSXI, NORM, SCALE, SSQ
16975 * .. Intrinsic Functions ..
16976  INTRINSIC abs, sqrt
16977 * ..
16978 * .. Executable Statements ..
16979  IF( n.LT.1 .OR. incx.LT.1 )THEN
16980  norm = zero
16981  ELSE IF( n.EQ.1 )THEN
16982  norm = abs( x( 1 ) )
16983  ELSE
16984  scale = zero
16985  ssq = one
16986 * The following loop is equivalent to this call to the LAPACK
16987 * auxiliary routine:
16988 * CALL SLASSQ( N, X, INCX, SCALE, SSQ )
16989 *
16990  DO 10, ix = 1, 1 + ( n - 1 )*incx, incx
16991  IF( x( ix ).NE.zero )THEN
16992  absxi = abs( x( ix ) )
16993  IF( scale.LT.absxi )THEN
16994  ssq = one + ssq*( scale/absxi )**2
16995  scale = absxi
16996  ELSE
16997  ssq = ssq + ( absxi/scale )**2
16998  END IF
16999  END IF
17000  10 CONTINUE
17001  norm = scale * sqrt( ssq )
17002  END IF
17003 *
17004  snrm2 = norm
17005  RETURN
17006 *
17007 * End of SNRM2.
17008 *
17009  END
17010  subroutine srot (n,sx,incx,sy,incy,c,s)
17011 c
17012 c applies a plane rotation.
17013 c jack dongarra, linpack, 3/11/78.
17014 c modified 12/3/93, array(1) declarations changed to array(*)
17015 c
17016  real sx(*),sy(*),stemp,c,s
17017  integer i,incx,incy,ix,iy,n
17018 c
17019  if(n.le.0)return
17020  if(incx.eq.1.and.incy.eq.1)go to 20
17021 c
17022 c code for unequal increments or equal increments not equal
17023 c to 1
17024 c
17025  ix = 1
17026  iy = 1
17027  if(incx.lt.0)ix = (-n+1)*incx + 1
17028  if(incy.lt.0)iy = (-n+1)*incy + 1
17029  do 10 i = 1,n
17030  stemp = c*sx(ix) + s*sy(iy)
17031  sy(iy) = c*sy(iy) - s*sx(ix)
17032  sx(ix) = stemp
17033  ix = ix + incx
17034  iy = iy + incy
17035  10 continue
17036  return
17037 c
17038 c code for both increments equal to 1
17039 c
17040  20 do 30 i = 1,n
17041  stemp = c*sx(i) + s*sy(i)
17042  sy(i) = c*sy(i) - s*sx(i)
17043  sx(i) = stemp
17044  30 continue
17045  return
17046  end
17047  subroutine srotg(sa,sb,c,s)
17048 c
17049 c construct givens plane rotation.
17050 c jack dongarra, linpack, 3/11/78.
17051 c
17052  real sa,sb,c,s,roe,scale,r,z
17053 c
17054  roe = sb
17055  if( abs(sa) .gt. abs(sb) ) roe = sa
17056  scale = abs(sa) + abs(sb)
17057  if( scale .ne. 0.0 ) go to 10
17058  c = 1.0
17059  s = 0.0
17060  r = 0.0
17061  z = 0.0
17062  go to 20
17063  10 r = scale*sqrt((sa/scale)**2 + (sb/scale)**2)
17064  r = sign(1.0,roe)*r
17065  c = sa/r
17066  s = sb/r
17067  z = 1.0
17068  if( abs(sa) .gt. abs(sb) ) z = s
17069  if( abs(sb) .ge. abs(sa) .and. c .ne. 0.0 ) z = 1.0/c
17070  20 sa = r
17071  sb = z
17072  return
17073  end
17074  SUBROUTINE srotm (N,SX,INCX,SY,INCY,SPARAM)
17075 C
17076 C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
17077 C
17078 C (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
17079 C (DX**T)
17080 C
17081 C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
17082 C LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
17083 C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
17084 C
17085 C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
17086 C
17087 C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
17088 C H=( ) ( ) ( ) ( )
17089 C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
17090 C SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
17091 C
17092  dimension sx(1),sy(1),sparam(5)
17093  DATA zero,two/0.e0,2.e0/
17094 C
17095  sflag=sparam(1)
17096  IF(n .LE. 0 .OR.(sflag+two.EQ.zero)) GO TO 140
17097  IF(.NOT.(incx.EQ.incy.AND. incx .GT.0)) GO TO 70
17098 C
17099  nsteps=n*incx
17100  IF(sflag) 50,10,30
17101  10 CONTINUE
17102  sh12=sparam(4)
17103  sh21=sparam(3)
17104  DO 20 i=1,nsteps,incx
17105  w=sx(i)
17106  z=sy(i)
17107  sx(i)=w+z*sh12
17108  sy(i)=w*sh21+z
17109  20 CONTINUE
17110  GO TO 140
17111  30 CONTINUE
17112  sh11=sparam(2)
17113  sh22=sparam(5)
17114  DO 40 i=1,nsteps,incx
17115  w=sx(i)
17116  z=sy(i)
17117  sx(i)=w*sh11+z
17118  sy(i)=-w+sh22*z
17119  40 CONTINUE
17120  GO TO 140
17121  50 CONTINUE
17122  sh11=sparam(2)
17123  sh12=sparam(4)
17124  sh21=sparam(3)
17125  sh22=sparam(5)
17126  DO 60 i=1,nsteps,incx
17127  w=sx(i)
17128  z=sy(i)
17129  sx(i)=w*sh11+z*sh12
17130  sy(i)=w*sh21+z*sh22
17131  60 CONTINUE
17132  GO TO 140
17133  70 CONTINUE
17134  kx=1
17135  ky=1
17136  IF(incx .LT. 0) kx=1+(1-n)*incx
17137  IF(incy .LT. 0) ky=1+(1-n)*incy
17138 C
17139  IF(sflag)120,80,100
17140  80 CONTINUE
17141  sh12=sparam(4)
17142  sh21=sparam(3)
17143  DO 90 i=1,n
17144  w=sx(kx)
17145  z=sy(ky)
17146  sx(kx)=w+z*sh12
17147  sy(ky)=w*sh21+z
17148  kx=kx+incx
17149  ky=ky+incy
17150  90 CONTINUE
17151  GO TO 140
17152  100 CONTINUE
17153  sh11=sparam(2)
17154  sh22=sparam(5)
17155  DO 110 i=1,n
17156  w=sx(kx)
17157  z=sy(ky)
17158  sx(kx)=w*sh11+z
17159  sy(ky)=-w+sh22*z
17160  kx=kx+incx
17161  ky=ky+incy
17162  110 CONTINUE
17163  GO TO 140
17164  120 CONTINUE
17165  sh11=sparam(2)
17166  sh12=sparam(4)
17167  sh21=sparam(3)
17168  sh22=sparam(5)
17169  DO 130 i=1,n
17170  w=sx(kx)
17171  z=sy(ky)
17172  sx(kx)=w*sh11+z*sh12
17173  sy(ky)=w*sh21+z*sh22
17174  kx=kx+incx
17175  ky=ky+incy
17176  130 CONTINUE
17177  140 CONTINUE
17178  RETURN
17179  END
17180  SUBROUTINE srotmg (SD1,SD2,SX1,SY1,SPARAM)
17181 C
17182 C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
17183 C THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
17184 C SY2)**T.
17185 C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
17186 C
17187 C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
17188 C
17189 C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
17190 C H=( ) ( ) ( ) ( )
17191 C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
17192 C LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
17193 C RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
17194 C VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
17195 C
17196 C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
17197 C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
17198 C OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
17199 C
17200  dimension sparam(5)
17201 C
17202  DATA zero,one,two /0.e0,1.e0,2.e0/
17203  DATA gam,gamsq,rgamsq/4096.e0,1.67772e7,5.96046e-8/
17204  IF(.NOT. sd1 .LT. zero) GO TO 10
17205 C GO ZERO-H-D-AND-SX1..
17206  GO TO 60
17207  10 CONTINUE
17208 C CASE-SD1-NONNEGATIVE
17209  sp2=sd2*sy1
17210  IF(.NOT. sp2 .EQ. zero) GO TO 20
17211  sflag=-two
17212  GO TO 260
17213 C REGULAR-CASE..
17214  20 CONTINUE
17215  sp1=sd1*sx1
17216  sq2=sp2*sy1
17217  sq1=sp1*sx1
17218 C
17219  IF(.NOT. abs(sq1) .GT. abs(sq2)) GO TO 40
17220  sh21=-sy1/sx1
17221  sh12=sp2/sp1
17222 C
17223  su=one-sh12*sh21
17224 C
17225  IF(.NOT. su .LE. zero) GO TO 30
17226 C GO ZERO-H-D-AND-SX1..
17227  GO TO 60
17228  30 CONTINUE
17229  sflag=zero
17230  sd1=sd1/su
17231  sd2=sd2/su
17232  sx1=sx1*su
17233 C GO SCALE-CHECK..
17234  GO TO 100
17235  40 CONTINUE
17236  IF(.NOT. sq2 .LT. zero) GO TO 50
17237 C GO ZERO-H-D-AND-SX1..
17238  GO TO 60
17239  50 CONTINUE
17240  sflag=one
17241  sh11=sp1/sp2
17242  sh22=sx1/sy1
17243  su=one+sh11*sh22
17244  stemp=sd2/su
17245  sd2=sd1/su
17246  sd1=stemp
17247  sx1=sy1*su
17248 C GO SCALE-CHECK
17249  GO TO 100
17250 C PROCEDURE..ZERO-H-D-AND-SX1..
17251  60 CONTINUE
17252  sflag=-one
17253  sh11=zero
17254  sh12=zero
17255  sh21=zero
17256  sh22=zero
17257 C
17258  sd1=zero
17259  sd2=zero
17260  sx1=zero
17261 C RETURN..
17262  GO TO 220
17263 C PROCEDURE..FIX-H..
17264  70 CONTINUE
17265  IF(.NOT. sflag .GE. zero) GO TO 90
17266 C
17267  IF(.NOT. sflag .EQ. zero) GO TO 80
17268  sh11=one
17269  sh22=one
17270  sflag=-one
17271  GO TO 90
17272  80 CONTINUE
17273  sh21=-one
17274  sh12=one
17275  sflag=-one
17276  90 CONTINUE
17277  GO TO igo,(120,150,180,210)
17278 C PROCEDURE..SCALE-CHECK
17279  100 CONTINUE
17280  110 CONTINUE
17281  IF(.NOT. sd1 .LE. rgamsq) GO TO 130
17282  IF(sd1 .EQ. zero) GO TO 160
17283  assign 120 to igo
17284 C FIX-H..
17285  GO TO 70
17286  120 CONTINUE
17287  sd1=sd1*gam**2
17288  sx1=sx1/gam
17289  sh11=sh11/gam
17290  sh12=sh12/gam
17291  GO TO 110
17292  130 CONTINUE
17293  140 CONTINUE
17294  IF(.NOT. sd1 .GE. gamsq) GO TO 160
17295  assign 150 to igo
17296 C FIX-H..
17297  GO TO 70
17298  150 CONTINUE
17299  sd1=sd1/gam**2
17300  sx1=sx1*gam
17301  sh11=sh11*gam
17302  sh12=sh12*gam
17303  GO TO 140
17304  160 CONTINUE
17305  170 CONTINUE
17306  IF(.NOT. abs(sd2) .LE. rgamsq) GO TO 190
17307  IF(sd2 .EQ. zero) GO TO 220
17308  assign 180 to igo
17309 C FIX-H..
17310  GO TO 70
17311  180 CONTINUE
17312  sd2=sd2*gam**2
17313  sh21=sh21/gam
17314  sh22=sh22/gam
17315  GO TO 170
17316  190 CONTINUE
17317  200 CONTINUE
17318  IF(.NOT. abs(sd2) .GE. gamsq) GO TO 220
17319  assign 210 to igo
17320 C FIX-H..
17321  GO TO 70
17322  210 CONTINUE
17323  sd2=sd2/gam**2
17324  sh21=sh21*gam
17325  sh22=sh22*gam
17326  GO TO 200
17327  220 CONTINUE
17328  IF(sflag)250,230,240
17329  230 CONTINUE
17330  sparam(3)=sh21
17331  sparam(4)=sh12
17332  GO TO 260
17333  240 CONTINUE
17334  sparam(2)=sh11
17335  sparam(5)=sh22
17336  GO TO 260
17337  250 CONTINUE
17338  sparam(2)=sh11
17339  sparam(3)=sh21
17340  sparam(4)=sh12
17341  sparam(5)=sh22
17342  260 CONTINUE
17343  sparam(1)=sflag
17344  RETURN
17345  END
17346  SUBROUTINE ssbmv ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
17347  $ beta, y, incy )
17348 * .. Scalar Arguments ..
17349  REAL ALPHA, BETA
17350  INTEGER INCX, INCY, K, LDA, N
17351  CHARACTER*1 UPLO
17352 * .. Array Arguments ..
17353  REAL A( lda, * ), X( * ), Y( * )
17354 * ..
17355 *
17356 * Purpose
17357 * =======
17358 *
17359 * SSBMV performs the matrix-vector operation
17360 *
17361 * y := alpha*A*x + beta*y,
17362 *
17363 * where alpha and beta are scalars, x and y are n element vectors and
17364 * A is an n by n symmetric band matrix, with k super-diagonals.
17365 *
17366 * Parameters
17367 * ==========
17368 *
17369 * UPLO - CHARACTER*1.
17370 * On entry, UPLO specifies whether the upper or lower
17371 * triangular part of the band matrix A is being supplied as
17372 * follows:
17373 *
17374 * UPLO = 'U' or 'u' The upper triangular part of A is
17375 * being supplied.
17376 *
17377 * UPLO = 'L' or 'l' The lower triangular part of A is
17378 * being supplied.
17379 *
17380 * Unchanged on exit.
17381 *
17382 * N - INTEGER.
17383 * On entry, N specifies the order of the matrix A.
17384 * N must be at least zero.
17385 * Unchanged on exit.
17386 *
17387 * K - INTEGER.
17388 * On entry, K specifies the number of super-diagonals of the
17389 * matrix A. K must satisfy 0 .le. K.
17390 * Unchanged on exit.
17391 *
17392 * ALPHA - REAL .
17393 * On entry, ALPHA specifies the scalar alpha.
17394 * Unchanged on exit.
17395 *
17396 * A - REAL array of DIMENSION ( LDA, n ).
17397 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
17398 * by n part of the array A must contain the upper triangular
17399 * band part of the symmetric matrix, supplied column by
17400 * column, with the leading diagonal of the matrix in row
17401 * ( k + 1 ) of the array, the first super-diagonal starting at
17402 * position 2 in row k, and so on. The top left k by k triangle
17403 * of the array A is not referenced.
17404 * The following program segment will transfer the upper
17405 * triangular part of a symmetric band matrix from conventional
17406 * full matrix storage to band storage:
17407 *
17408 * DO 20, J = 1, N
17409 * M = K + 1 - J
17410 * DO 10, I = MAX( 1, J - K ), J
17411 * A( M + I, J ) = matrix( I, J )
17412 * 10 CONTINUE
17413 * 20 CONTINUE
17414 *
17415 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
17416 * by n part of the array A must contain the lower triangular
17417 * band part of the symmetric matrix, supplied column by
17418 * column, with the leading diagonal of the matrix in row 1 of
17419 * the array, the first sub-diagonal starting at position 1 in
17420 * row 2, and so on. The bottom right k by k triangle of the
17421 * array A is not referenced.
17422 * The following program segment will transfer the lower
17423 * triangular part of a symmetric band matrix from conventional
17424 * full matrix storage to band storage:
17425 *
17426 * DO 20, J = 1, N
17427 * M = 1 - J
17428 * DO 10, I = J, MIN( N, J + K )
17429 * A( M + I, J ) = matrix( I, J )
17430 * 10 CONTINUE
17431 * 20 CONTINUE
17432 *
17433 * Unchanged on exit.
17434 *
17435 * LDA - INTEGER.
17436 * On entry, LDA specifies the first dimension of A as declared
17437 * in the calling (sub) program. LDA must be at least
17438 * ( k + 1 ).
17439 * Unchanged on exit.
17440 *
17441 * X - REAL array of DIMENSION at least
17442 * ( 1 + ( n - 1 )*abs( INCX ) ).
17443 * Before entry, the incremented array X must contain the
17444 * vector x.
17445 * Unchanged on exit.
17446 *
17447 * INCX - INTEGER.
17448 * On entry, INCX specifies the increment for the elements of
17449 * X. INCX must not be zero.
17450 * Unchanged on exit.
17451 *
17452 * BETA - REAL .
17453 * On entry, BETA specifies the scalar beta.
17454 * Unchanged on exit.
17455 *
17456 * Y - REAL array of DIMENSION at least
17457 * ( 1 + ( n - 1 )*abs( INCY ) ).
17458 * Before entry, the incremented array Y must contain the
17459 * vector y. On exit, Y is overwritten by the updated vector y.
17460 *
17461 * INCY - INTEGER.
17462 * On entry, INCY specifies the increment for the elements of
17463 * Y. INCY must not be zero.
17464 * Unchanged on exit.
17465 *
17466 *
17467 * Level 2 Blas routine.
17468 *
17469 * -- Written on 22-October-1986.
17470 * Jack Dongarra, Argonne National Lab.
17471 * Jeremy Du Croz, Nag Central Office.
17472 * Sven Hammarling, Nag Central Office.
17473 * Richard Hanson, Sandia National Labs.
17474 *
17475 *
17476 * .. Parameters ..
17477  REAL ONE , ZERO
17478  parameter( one = 1.0e+0, zero = 0.0e+0 )
17479 * .. Local Scalars ..
17480  REAL TEMP1, TEMP2
17481  INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
17482 * .. External Functions ..
17483  LOGICAL LSAME
17484  EXTERNAL lsame
17485 * .. External Subroutines ..
17486  EXTERNAL xerbla
17487 * .. Intrinsic Functions ..
17488  INTRINSIC max, min
17489 * ..
17490 * .. Executable Statements ..
17491 *
17492 * Test the input parameters.
17493 *
17494  info = 0
17495  IF ( .NOT.lsame( uplo, 'U' ).AND.
17496  $ .NOT.lsame( uplo, 'L' ) )THEN
17497  info = 1
17498  ELSE IF( n.LT.0 )THEN
17499  info = 2
17500  ELSE IF( k.LT.0 )THEN
17501  info = 3
17502  ELSE IF( lda.LT.( k + 1 ) )THEN
17503  info = 6
17504  ELSE IF( incx.EQ.0 )THEN
17505  info = 8
17506  ELSE IF( incy.EQ.0 )THEN
17507  info = 11
17508  END IF
17509  IF( info.NE.0 )THEN
17510  CALL xerbla( 'SSBMV ', info )
17511  RETURN
17512  END IF
17513 *
17514 * Quick return if possible.
17515 *
17516  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
17517  $ RETURN
17518 *
17519 * Set up the start points in X and Y.
17520 *
17521  IF( incx.GT.0 )THEN
17522  kx = 1
17523  ELSE
17524  kx = 1 - ( n - 1 )*incx
17525  END IF
17526  IF( incy.GT.0 )THEN
17527  ky = 1
17528  ELSE
17529  ky = 1 - ( n - 1 )*incy
17530  END IF
17531 *
17532 * Start the operations. In this version the elements of the array A
17533 * are accessed sequentially with one pass through A.
17534 *
17535 * First form y := beta*y.
17536 *
17537  IF( beta.NE.one )THEN
17538  IF( incy.EQ.1 )THEN
17539  IF( beta.EQ.zero )THEN
17540  DO 10, i = 1, n
17541  y( i ) = zero
17542  10 CONTINUE
17543  ELSE
17544  DO 20, i = 1, n
17545  y( i ) = beta*y( i )
17546  20 CONTINUE
17547  END IF
17548  ELSE
17549  iy = ky
17550  IF( beta.EQ.zero )THEN
17551  DO 30, i = 1, n
17552  y( iy ) = zero
17553  iy = iy + incy
17554  30 CONTINUE
17555  ELSE
17556  DO 40, i = 1, n
17557  y( iy ) = beta*y( iy )
17558  iy = iy + incy
17559  40 CONTINUE
17560  END IF
17561  END IF
17562  END IF
17563  IF( alpha.EQ.zero )
17564  $ RETURN
17565  IF( lsame( uplo, 'U' ) )THEN
17566 *
17567 * Form y when upper triangle of A is stored.
17568 *
17569  kplus1 = k + 1
17570  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
17571  DO 60, j = 1, n
17572  temp1 = alpha*x( j )
17573  temp2 = zero
17574  l = kplus1 - j
17575  DO 50, i = max( 1, j - k ), j - 1
17576  y( i ) = y( i ) + temp1*a( l + i, j )
17577  temp2 = temp2 + a( l + i, j )*x( i )
17578  50 CONTINUE
17579  y( j ) = y( j ) + temp1*a( kplus1, j ) + alpha*temp2
17580  60 CONTINUE
17581  ELSE
17582  jx = kx
17583  jy = ky
17584  DO 80, j = 1, n
17585  temp1 = alpha*x( jx )
17586  temp2 = zero
17587  ix = kx
17588  iy = ky
17589  l = kplus1 - j
17590  DO 70, i = max( 1, j - k ), j - 1
17591  y( iy ) = y( iy ) + temp1*a( l + i, j )
17592  temp2 = temp2 + a( l + i, j )*x( ix )
17593  ix = ix + incx
17594  iy = iy + incy
17595  70 CONTINUE
17596  y( jy ) = y( jy ) + temp1*a( kplus1, j ) + alpha*temp2
17597  jx = jx + incx
17598  jy = jy + incy
17599  IF( j.GT.k )THEN
17600  kx = kx + incx
17601  ky = ky + incy
17602  END IF
17603  80 CONTINUE
17604  END IF
17605  ELSE
17606 *
17607 * Form y when lower triangle of A is stored.
17608 *
17609  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
17610  DO 100, j = 1, n
17611  temp1 = alpha*x( j )
17612  temp2 = zero
17613  y( j ) = y( j ) + temp1*a( 1, j )
17614  l = 1 - j
17615  DO 90, i = j + 1, min( n, j + k )
17616  y( i ) = y( i ) + temp1*a( l + i, j )
17617  temp2 = temp2 + a( l + i, j )*x( i )
17618  90 CONTINUE
17619  y( j ) = y( j ) + alpha*temp2
17620  100 CONTINUE
17621  ELSE
17622  jx = kx
17623  jy = ky
17624  DO 120, j = 1, n
17625  temp1 = alpha*x( jx )
17626  temp2 = zero
17627  y( jy ) = y( jy ) + temp1*a( 1, j )
17628  l = 1 - j
17629  ix = jx
17630  iy = jy
17631  DO 110, i = j + 1, min( n, j + k )
17632  ix = ix + incx
17633  iy = iy + incy
17634  y( iy ) = y( iy ) + temp1*a( l + i, j )
17635  temp2 = temp2 + a( l + i, j )*x( ix )
17636  110 CONTINUE
17637  y( jy ) = y( jy ) + alpha*temp2
17638  jx = jx + incx
17639  jy = jy + incy
17640  120 CONTINUE
17641  END IF
17642  END IF
17643 *
17644  RETURN
17645 *
17646 * End of SSBMV .
17647 *
17648  END
17649  subroutine sscal(n,sa,sx,incx)
17650 c
17651 c scales a vector by a constant.
17652 c uses unrolled loops for increment equal to 1.
17653 c jack dongarra, linpack, 3/11/78.
17654 c modified 3/93 to return if incx .le. 0.
17655 c modified 12/3/93, array(1) declarations changed to array(*)
17656 c
17657  real sa,sx(*)
17658  integer i,incx,m,mp1,n,nincx
17659 c
17660  if( n.le.0 .or. incx.le.0 )return
17661  if(incx.eq.1)go to 20
17662 c
17663 c code for increment not equal to 1
17664 c
17665  nincx = n*incx
17666  do 10 i = 1,nincx,incx
17667  sx(i) = sa*sx(i)
17668  10 continue
17669  return
17670 c
17671 c code for increment equal to 1
17672 c
17673 c
17674 c clean-up loop
17675 c
17676  20 m = mod(n,5)
17677  if( m .eq. 0 ) go to 40
17678  do 30 i = 1,m
17679  sx(i) = sa*sx(i)
17680  30 continue
17681  if( n .lt. 5 ) return
17682  40 mp1 = m + 1
17683  do 50 i = mp1,n,5
17684  sx(i) = sa*sx(i)
17685  sx(i + 1) = sa*sx(i + 1)
17686  sx(i + 2) = sa*sx(i + 2)
17687  sx(i + 3) = sa*sx(i + 3)
17688  sx(i + 4) = sa*sx(i + 4)
17689  50 continue
17690  return
17691  end
17692  SUBROUTINE sspmv ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
17693 * .. Scalar Arguments ..
17694  REAL ALPHA, BETA
17695  INTEGER INCX, INCY, N
17696  CHARACTER*1 UPLO
17697 * .. Array Arguments ..
17698  REAL AP( * ), X( * ), Y( * )
17699 * ..
17700 *
17701 * Purpose
17702 * =======
17703 *
17704 * SSPMV performs the matrix-vector operation
17705 *
17706 * y := alpha*A*x + beta*y,
17707 *
17708 * where alpha and beta are scalars, x and y are n element vectors and
17709 * A is an n by n symmetric matrix, supplied in packed form.
17710 *
17711 * Parameters
17712 * ==========
17713 *
17714 * UPLO - CHARACTER*1.
17715 * On entry, UPLO specifies whether the upper or lower
17716 * triangular part of the matrix A is supplied in the packed
17717 * array AP as follows:
17718 *
17719 * UPLO = 'U' or 'u' The upper triangular part of A is
17720 * supplied in AP.
17721 *
17722 * UPLO = 'L' or 'l' The lower triangular part of A is
17723 * supplied in AP.
17724 *
17725 * Unchanged on exit.
17726 *
17727 * N - INTEGER.
17728 * On entry, N specifies the order of the matrix A.
17729 * N must be at least zero.
17730 * Unchanged on exit.
17731 *
17732 * ALPHA - REAL .
17733 * On entry, ALPHA specifies the scalar alpha.
17734 * Unchanged on exit.
17735 *
17736 * AP - REAL array of DIMENSION at least
17737 * ( ( n*( n + 1 ) )/2 ).
17738 * Before entry with UPLO = 'U' or 'u', the array AP must
17739 * contain the upper triangular part of the symmetric matrix
17740 * packed sequentially, column by column, so that AP( 1 )
17741 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
17742 * and a( 2, 2 ) respectively, and so on.
17743 * Before entry with UPLO = 'L' or 'l', the array AP must
17744 * contain the lower triangular part of the symmetric matrix
17745 * packed sequentially, column by column, so that AP( 1 )
17746 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
17747 * and a( 3, 1 ) respectively, and so on.
17748 * Unchanged on exit.
17749 *
17750 * X - REAL array of dimension at least
17751 * ( 1 + ( n - 1 )*abs( INCX ) ).
17752 * Before entry, the incremented array X must contain the n
17753 * element vector x.
17754 * Unchanged on exit.
17755 *
17756 * INCX - INTEGER.
17757 * On entry, INCX specifies the increment for the elements of
17758 * X. INCX must not be zero.
17759 * Unchanged on exit.
17760 *
17761 * BETA - REAL .
17762 * On entry, BETA specifies the scalar beta. When BETA is
17763 * supplied as zero then Y need not be set on input.
17764 * Unchanged on exit.
17765 *
17766 * Y - REAL array of dimension at least
17767 * ( 1 + ( n - 1 )*abs( INCY ) ).
17768 * Before entry, the incremented array Y must contain the n
17769 * element vector y. On exit, Y is overwritten by the updated
17770 * vector y.
17771 *
17772 * INCY - INTEGER.
17773 * On entry, INCY specifies the increment for the elements of
17774 * Y. INCY must not be zero.
17775 * Unchanged on exit.
17776 *
17777 *
17778 * Level 2 Blas routine.
17779 *
17780 * -- Written on 22-October-1986.
17781 * Jack Dongarra, Argonne National Lab.
17782 * Jeremy Du Croz, Nag Central Office.
17783 * Sven Hammarling, Nag Central Office.
17784 * Richard Hanson, Sandia National Labs.
17785 *
17786 *
17787 * .. Parameters ..
17788  REAL ONE , ZERO
17789  parameter( one = 1.0e+0, zero = 0.0e+0 )
17790 * .. Local Scalars ..
17791  REAL TEMP1, TEMP2
17792  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
17793 * .. External Functions ..
17794  LOGICAL LSAME
17795  EXTERNAL lsame
17796 * .. External Subroutines ..
17797  EXTERNAL xerbla
17798 * ..
17799 * .. Executable Statements ..
17800 *
17801 * Test the input parameters.
17802 *
17803  info = 0
17804  IF ( .NOT.lsame( uplo, 'U' ).AND.
17805  $ .NOT.lsame( uplo, 'L' ) )THEN
17806  info = 1
17807  ELSE IF( n.LT.0 )THEN
17808  info = 2
17809  ELSE IF( incx.EQ.0 )THEN
17810  info = 6
17811  ELSE IF( incy.EQ.0 )THEN
17812  info = 9
17813  END IF
17814  IF( info.NE.0 )THEN
17815  CALL xerbla( 'SSPMV ', info )
17816  RETURN
17817  END IF
17818 *
17819 * Quick return if possible.
17820 *
17821  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
17822  $ RETURN
17823 *
17824 * Set up the start points in X and Y.
17825 *
17826  IF( incx.GT.0 )THEN
17827  kx = 1
17828  ELSE
17829  kx = 1 - ( n - 1 )*incx
17830  END IF
17831  IF( incy.GT.0 )THEN
17832  ky = 1
17833  ELSE
17834  ky = 1 - ( n - 1 )*incy
17835  END IF
17836 *
17837 * Start the operations. In this version the elements of the array AP
17838 * are accessed sequentially with one pass through AP.
17839 *
17840 * First form y := beta*y.
17841 *
17842  IF( beta.NE.one )THEN
17843  IF( incy.EQ.1 )THEN
17844  IF( beta.EQ.zero )THEN
17845  DO 10, i = 1, n
17846  y( i ) = zero
17847  10 CONTINUE
17848  ELSE
17849  DO 20, i = 1, n
17850  y( i ) = beta*y( i )
17851  20 CONTINUE
17852  END IF
17853  ELSE
17854  iy = ky
17855  IF( beta.EQ.zero )THEN
17856  DO 30, i = 1, n
17857  y( iy ) = zero
17858  iy = iy + incy
17859  30 CONTINUE
17860  ELSE
17861  DO 40, i = 1, n
17862  y( iy ) = beta*y( iy )
17863  iy = iy + incy
17864  40 CONTINUE
17865  END IF
17866  END IF
17867  END IF
17868  IF( alpha.EQ.zero )
17869  $ RETURN
17870  kk = 1
17871  IF( lsame( uplo, 'U' ) )THEN
17872 *
17873 * Form y when AP contains the upper triangle.
17874 *
17875  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
17876  DO 60, j = 1, n
17877  temp1 = alpha*x( j )
17878  temp2 = zero
17879  k = kk
17880  DO 50, i = 1, j - 1
17881  y( i ) = y( i ) + temp1*ap( k )
17882  temp2 = temp2 + ap( k )*x( i )
17883  k = k + 1
17884  50 CONTINUE
17885  y( j ) = y( j ) + temp1*ap( kk + j - 1 ) + alpha*temp2
17886  kk = kk + j
17887  60 CONTINUE
17888  ELSE
17889  jx = kx
17890  jy = ky
17891  DO 80, j = 1, n
17892  temp1 = alpha*x( jx )
17893  temp2 = zero
17894  ix = kx
17895  iy = ky
17896  DO 70, k = kk, kk + j - 2
17897  y( iy ) = y( iy ) + temp1*ap( k )
17898  temp2 = temp2 + ap( k )*x( ix )
17899  ix = ix + incx
17900  iy = iy + incy
17901  70 CONTINUE
17902  y( jy ) = y( jy ) + temp1*ap( kk + j - 1 ) + alpha*temp2
17903  jx = jx + incx
17904  jy = jy + incy
17905  kk = kk + j
17906  80 CONTINUE
17907  END IF
17908  ELSE
17909 *
17910 * Form y when AP contains the lower triangle.
17911 *
17912  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
17913  DO 100, j = 1, n
17914  temp1 = alpha*x( j )
17915  temp2 = zero
17916  y( j ) = y( j ) + temp1*ap( kk )
17917  k = kk + 1
17918  DO 90, i = j + 1, n
17919  y( i ) = y( i ) + temp1*ap( k )
17920  temp2 = temp2 + ap( k )*x( i )
17921  k = k + 1
17922  90 CONTINUE
17923  y( j ) = y( j ) + alpha*temp2
17924  kk = kk + ( n - j + 1 )
17925  100 CONTINUE
17926  ELSE
17927  jx = kx
17928  jy = ky
17929  DO 120, j = 1, n
17930  temp1 = alpha*x( jx )
17931  temp2 = zero
17932  y( jy ) = y( jy ) + temp1*ap( kk )
17933  ix = jx
17934  iy = jy
17935  DO 110, k = kk + 1, kk + n - j
17936  ix = ix + incx
17937  iy = iy + incy
17938  y( iy ) = y( iy ) + temp1*ap( k )
17939  temp2 = temp2 + ap( k )*x( ix )
17940  110 CONTINUE
17941  y( jy ) = y( jy ) + alpha*temp2
17942  jx = jx + incx
17943  jy = jy + incy
17944  kk = kk + ( n - j + 1 )
17945  120 CONTINUE
17946  END IF
17947  END IF
17948 *
17949  RETURN
17950 *
17951 * End of SSPMV .
17952 *
17953  END
17954  SUBROUTINE sspr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
17955 * .. Scalar Arguments ..
17956  REAL ALPHA
17957  INTEGER INCX, INCY, N
17958  CHARACTER*1 UPLO
17959 * .. Array Arguments ..
17960  REAL AP( * ), X( * ), Y( * )
17961 * ..
17962 *
17963 * Purpose
17964 * =======
17965 *
17966 * SSPR2 performs the symmetric rank 2 operation
17967 *
17968 * A := alpha*x*y' + alpha*y*x' + A,
17969 *
17970 * where alpha is a scalar, x and y are n element vectors and A is an
17971 * n by n symmetric matrix, supplied in packed form.
17972 *
17973 * Parameters
17974 * ==========
17975 *
17976 * UPLO - CHARACTER*1.
17977 * On entry, UPLO specifies whether the upper or lower
17978 * triangular part of the matrix A is supplied in the packed
17979 * array AP as follows:
17980 *
17981 * UPLO = 'U' or 'u' The upper triangular part of A is
17982 * supplied in AP.
17983 *
17984 * UPLO = 'L' or 'l' The lower triangular part of A is
17985 * supplied in AP.
17986 *
17987 * Unchanged on exit.
17988 *
17989 * N - INTEGER.
17990 * On entry, N specifies the order of the matrix A.
17991 * N must be at least zero.
17992 * Unchanged on exit.
17993 *
17994 * ALPHA - REAL .
17995 * On entry, ALPHA specifies the scalar alpha.
17996 * Unchanged on exit.
17997 *
17998 * X - REAL array of dimension at least
17999 * ( 1 + ( n - 1 )*abs( INCX ) ).
18000 * Before entry, the incremented array X must contain the n
18001 * element vector x.
18002 * Unchanged on exit.
18003 *
18004 * INCX - INTEGER.
18005 * On entry, INCX specifies the increment for the elements of
18006 * X. INCX must not be zero.
18007 * Unchanged on exit.
18008 *
18009 * Y - REAL array of dimension at least
18010 * ( 1 + ( n - 1 )*abs( INCY ) ).
18011 * Before entry, the incremented array Y must contain the n
18012 * element vector y.
18013 * Unchanged on exit.
18014 *
18015 * INCY - INTEGER.
18016 * On entry, INCY specifies the increment for the elements of
18017 * Y. INCY must not be zero.
18018 * Unchanged on exit.
18019 *
18020 * AP - REAL array of DIMENSION at least
18021 * ( ( n*( n + 1 ) )/2 ).
18022 * Before entry with UPLO = 'U' or 'u', the array AP must
18023 * contain the upper triangular part of the symmetric matrix
18024 * packed sequentially, column by column, so that AP( 1 )
18025 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
18026 * and a( 2, 2 ) respectively, and so on. On exit, the array
18027 * AP is overwritten by the upper triangular part of the
18028 * updated matrix.
18029 * Before entry with UPLO = 'L' or 'l', the array AP must
18030 * contain the lower triangular part of the symmetric matrix
18031 * packed sequentially, column by column, so that AP( 1 )
18032 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
18033 * and a( 3, 1 ) respectively, and so on. On exit, the array
18034 * AP is overwritten by the lower triangular part of the
18035 * updated matrix.
18036 *
18037 *
18038 * Level 2 Blas routine.
18039 *
18040 * -- Written on 22-October-1986.
18041 * Jack Dongarra, Argonne National Lab.
18042 * Jeremy Du Croz, Nag Central Office.
18043 * Sven Hammarling, Nag Central Office.
18044 * Richard Hanson, Sandia National Labs.
18045 *
18046 *
18047 * .. Parameters ..
18048  REAL ZERO
18049  parameter( zero = 0.0e+0 )
18050 * .. Local Scalars ..
18051  REAL TEMP1, TEMP2
18052  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
18053 * .. External Functions ..
18054  LOGICAL LSAME
18055  EXTERNAL lsame
18056 * .. External Subroutines ..
18057  EXTERNAL xerbla
18058 * ..
18059 * .. Executable Statements ..
18060 *
18061 * Test the input parameters.
18062 *
18063  info = 0
18064  IF ( .NOT.lsame( uplo, 'U' ).AND.
18065  $ .NOT.lsame( uplo, 'L' ) )THEN
18066  info = 1
18067  ELSE IF( n.LT.0 )THEN
18068  info = 2
18069  ELSE IF( incx.EQ.0 )THEN
18070  info = 5
18071  ELSE IF( incy.EQ.0 )THEN
18072  info = 7
18073  END IF
18074  IF( info.NE.0 )THEN
18075  CALL xerbla( 'SSPR2 ', info )
18076  RETURN
18077  END IF
18078 *
18079 * Quick return if possible.
18080 *
18081  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
18082  $ RETURN
18083 *
18084 * Set up the start points in X and Y if the increments are not both
18085 * unity.
18086 *
18087  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
18088  IF( incx.GT.0 )THEN
18089  kx = 1
18090  ELSE
18091  kx = 1 - ( n - 1 )*incx
18092  END IF
18093  IF( incy.GT.0 )THEN
18094  ky = 1
18095  ELSE
18096  ky = 1 - ( n - 1 )*incy
18097  END IF
18098  jx = kx
18099  jy = ky
18100  END IF
18101 *
18102 * Start the operations. In this version the elements of the array AP
18103 * are accessed sequentially with one pass through AP.
18104 *
18105  kk = 1
18106  IF( lsame( uplo, 'U' ) )THEN
18107 *
18108 * Form A when upper triangle is stored in AP.
18109 *
18110  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
18111  DO 20, j = 1, n
18112  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
18113  temp1 = alpha*y( j )
18114  temp2 = alpha*x( j )
18115  k = kk
18116  DO 10, i = 1, j
18117  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
18118  k = k + 1
18119  10 CONTINUE
18120  END IF
18121  kk = kk + j
18122  20 CONTINUE
18123  ELSE
18124  DO 40, j = 1, n
18125  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
18126  temp1 = alpha*y( jy )
18127  temp2 = alpha*x( jx )
18128  ix = kx
18129  iy = ky
18130  DO 30, k = kk, kk + j - 1
18131  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
18132  ix = ix + incx
18133  iy = iy + incy
18134  30 CONTINUE
18135  END IF
18136  jx = jx + incx
18137  jy = jy + incy
18138  kk = kk + j
18139  40 CONTINUE
18140  END IF
18141  ELSE
18142 *
18143 * Form A when lower triangle is stored in AP.
18144 *
18145  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
18146  DO 60, j = 1, n
18147  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
18148  temp1 = alpha*y( j )
18149  temp2 = alpha*x( j )
18150  k = kk
18151  DO 50, i = j, n
18152  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
18153  k = k + 1
18154  50 CONTINUE
18155  END IF
18156  kk = kk + n - j + 1
18157  60 CONTINUE
18158  ELSE
18159  DO 80, j = 1, n
18160  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
18161  temp1 = alpha*y( jy )
18162  temp2 = alpha*x( jx )
18163  ix = jx
18164  iy = jy
18165  DO 70, k = kk, kk + n - j
18166  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
18167  ix = ix + incx
18168  iy = iy + incy
18169  70 CONTINUE
18170  END IF
18171  jx = jx + incx
18172  jy = jy + incy
18173  kk = kk + n - j + 1
18174  80 CONTINUE
18175  END IF
18176  END IF
18177 *
18178  RETURN
18179 *
18180 * End of SSPR2 .
18181 *
18182  END
18183  SUBROUTINE sspr ( UPLO, N, ALPHA, X, INCX, AP )
18184 * .. Scalar Arguments ..
18185  REAL ALPHA
18186  INTEGER INCX, N
18187  CHARACTER*1 UPLO
18188 * .. Array Arguments ..
18189  REAL AP( * ), X( * )
18190 * ..
18191 *
18192 * Purpose
18193 * =======
18194 *
18195 * SSPR performs the symmetric rank 1 operation
18196 *
18197 * A := alpha*x*x' + A,
18198 *
18199 * where alpha is a real scalar, x is an n element vector and A is an
18200 * n by n symmetric matrix, supplied in packed form.
18201 *
18202 * Parameters
18203 * ==========
18204 *
18205 * UPLO - CHARACTER*1.
18206 * On entry, UPLO specifies whether the upper or lower
18207 * triangular part of the matrix A is supplied in the packed
18208 * array AP as follows:
18209 *
18210 * UPLO = 'U' or 'u' The upper triangular part of A is
18211 * supplied in AP.
18212 *
18213 * UPLO = 'L' or 'l' The lower triangular part of A is
18214 * supplied in AP.
18215 *
18216 * Unchanged on exit.
18217 *
18218 * N - INTEGER.
18219 * On entry, N specifies the order of the matrix A.
18220 * N must be at least zero.
18221 * Unchanged on exit.
18222 *
18223 * ALPHA - REAL .
18224 * On entry, ALPHA specifies the scalar alpha.
18225 * Unchanged on exit.
18226 *
18227 * X - REAL array of dimension at least
18228 * ( 1 + ( n - 1 )*abs( INCX ) ).
18229 * Before entry, the incremented array X must contain the n
18230 * element vector x.
18231 * Unchanged on exit.
18232 *
18233 * INCX - INTEGER.
18234 * On entry, INCX specifies the increment for the elements of
18235 * X. INCX must not be zero.
18236 * Unchanged on exit.
18237 *
18238 * AP - REAL array of DIMENSION at least
18239 * ( ( n*( n + 1 ) )/2 ).
18240 * Before entry with UPLO = 'U' or 'u', the array AP must
18241 * contain the upper triangular part of the symmetric matrix
18242 * packed sequentially, column by column, so that AP( 1 )
18243 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
18244 * and a( 2, 2 ) respectively, and so on. On exit, the array
18245 * AP is overwritten by the upper triangular part of the
18246 * updated matrix.
18247 * Before entry with UPLO = 'L' or 'l', the array AP must
18248 * contain the lower triangular part of the symmetric matrix
18249 * packed sequentially, column by column, so that AP( 1 )
18250 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
18251 * and a( 3, 1 ) respectively, and so on. On exit, the array
18252 * AP is overwritten by the lower triangular part of the
18253 * updated matrix.
18254 *
18255 *
18256 * Level 2 Blas routine.
18257 *
18258 * -- Written on 22-October-1986.
18259 * Jack Dongarra, Argonne National Lab.
18260 * Jeremy Du Croz, Nag Central Office.
18261 * Sven Hammarling, Nag Central Office.
18262 * Richard Hanson, Sandia National Labs.
18263 *
18264 *
18265 * .. Parameters ..
18266  REAL ZERO
18267  parameter( zero = 0.0e+0 )
18268 * .. Local Scalars ..
18269  REAL TEMP
18270  INTEGER I, INFO, IX, J, JX, K, KK, KX
18271 * .. External Functions ..
18272  LOGICAL LSAME
18273  EXTERNAL lsame
18274 * .. External Subroutines ..
18275  EXTERNAL xerbla
18276 * ..
18277 * .. Executable Statements ..
18278 *
18279 * Test the input parameters.
18280 *
18281  info = 0
18282  IF ( .NOT.lsame( uplo, 'U' ).AND.
18283  $ .NOT.lsame( uplo, 'L' ) )THEN
18284  info = 1
18285  ELSE IF( n.LT.0 )THEN
18286  info = 2
18287  ELSE IF( incx.EQ.0 )THEN
18288  info = 5
18289  END IF
18290  IF( info.NE.0 )THEN
18291  CALL xerbla( 'SSPR ', info )
18292  RETURN
18293  END IF
18294 *
18295 * Quick return if possible.
18296 *
18297  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
18298  $ RETURN
18299 *
18300 * Set the start point in X if the increment is not unity.
18301 *
18302  IF( incx.LE.0 )THEN
18303  kx = 1 - ( n - 1 )*incx
18304  ELSE IF( incx.NE.1 )THEN
18305  kx = 1
18306  END IF
18307 *
18308 * Start the operations. In this version the elements of the array AP
18309 * are accessed sequentially with one pass through AP.
18310 *
18311  kk = 1
18312  IF( lsame( uplo, 'U' ) )THEN
18313 *
18314 * Form A when upper triangle is stored in AP.
18315 *
18316  IF( incx.EQ.1 )THEN
18317  DO 20, j = 1, n
18318  IF( x( j ).NE.zero )THEN
18319  temp = alpha*x( j )
18320  k = kk
18321  DO 10, i = 1, j
18322  ap( k ) = ap( k ) + x( i )*temp
18323  k = k + 1
18324  10 CONTINUE
18325  END IF
18326  kk = kk + j
18327  20 CONTINUE
18328  ELSE
18329  jx = kx
18330  DO 40, j = 1, n
18331  IF( x( jx ).NE.zero )THEN
18332  temp = alpha*x( jx )
18333  ix = kx
18334  DO 30, k = kk, kk + j - 1
18335  ap( k ) = ap( k ) + x( ix )*temp
18336  ix = ix + incx
18337  30 CONTINUE
18338  END IF
18339  jx = jx + incx
18340  kk = kk + j
18341  40 CONTINUE
18342  END IF
18343  ELSE
18344 *
18345 * Form A when lower triangle is stored in AP.
18346 *
18347  IF( incx.EQ.1 )THEN
18348  DO 60, j = 1, n
18349  IF( x( j ).NE.zero )THEN
18350  temp = alpha*x( j )
18351  k = kk
18352  DO 50, i = j, n
18353  ap( k ) = ap( k ) + x( i )*temp
18354  k = k + 1
18355  50 CONTINUE
18356  END IF
18357  kk = kk + n - j + 1
18358  60 CONTINUE
18359  ELSE
18360  jx = kx
18361  DO 80, j = 1, n
18362  IF( x( jx ).NE.zero )THEN
18363  temp = alpha*x( jx )
18364  ix = jx
18365  DO 70, k = kk, kk + n - j
18366  ap( k ) = ap( k ) + x( ix )*temp
18367  ix = ix + incx
18368  70 CONTINUE
18369  END IF
18370  jx = jx + incx
18371  kk = kk + n - j + 1
18372  80 CONTINUE
18373  END IF
18374  END IF
18375 *
18376  RETURN
18377 *
18378 * End of SSPR .
18379 *
18380  END
18381  subroutine sswap (n,sx,incx,sy,incy)
18382 c
18383 c interchanges two vectors.
18384 c uses unrolled loops for increments equal to 1.
18385 c jack dongarra, linpack, 3/11/78.
18386 c modified 12/3/93, array(1) declarations changed to array(*)
18387 c
18388  real sx(*),sy(*),stemp
18389  integer i,incx,incy,ix,iy,m,mp1,n
18390 c
18391  if(n.le.0)return
18392  if(incx.eq.1.and.incy.eq.1)go to 20
18393 c
18394 c code for unequal increments or equal increments not equal
18395 c to 1
18396 c
18397  ix = 1
18398  iy = 1
18399  if(incx.lt.0)ix = (-n+1)*incx + 1
18400  if(incy.lt.0)iy = (-n+1)*incy + 1
18401  do 10 i = 1,n
18402  stemp = sx(ix)
18403  sx(ix) = sy(iy)
18404  sy(iy) = stemp
18405  ix = ix + incx
18406  iy = iy + incy
18407  10 continue
18408  return
18409 c
18410 c code for both increments equal to 1
18411 c
18412 c
18413 c clean-up loop
18414 c
18415  20 m = mod(n,3)
18416  if( m .eq. 0 ) go to 40
18417  do 30 i = 1,m
18418  stemp = sx(i)
18419  sx(i) = sy(i)
18420  sy(i) = stemp
18421  30 continue
18422  if( n .lt. 3 ) return
18423  40 mp1 = m + 1
18424  do 50 i = mp1,n,3
18425  stemp = sx(i)
18426  sx(i) = sy(i)
18427  sy(i) = stemp
18428  stemp = sx(i + 1)
18429  sx(i + 1) = sy(i + 1)
18430  sy(i + 1) = stemp
18431  stemp = sx(i + 2)
18432  sx(i + 2) = sy(i + 2)
18433  sy(i + 2) = stemp
18434  50 continue
18435  return
18436  end
18437  SUBROUTINE ssymm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
18438  $ beta, c, ldc )
18439 * .. Scalar Arguments ..
18440  CHARACTER*1 SIDE, UPLO
18441  INTEGER M, N, LDA, LDB, LDC
18442  REAL ALPHA, BETA
18443 * .. Array Arguments ..
18444  REAL A( lda, * ), B( ldb, * ), C( ldc, * )
18445 * ..
18446 *
18447 * Purpose
18448 * =======
18449 *
18450 * SSYMM performs one of the matrix-matrix operations
18451 *
18452 * C := alpha*A*B + beta*C,
18453 *
18454 * or
18455 *
18456 * C := alpha*B*A + beta*C,
18457 *
18458 * where alpha and beta are scalars, A is a symmetric matrix and B and
18459 * C are m by n matrices.
18460 *
18461 * Parameters
18462 * ==========
18463 *
18464 * SIDE - CHARACTER*1.
18465 * On entry, SIDE specifies whether the symmetric matrix A
18466 * appears on the left or right in the operation as follows:
18467 *
18468 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
18469 *
18470 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
18471 *
18472 * Unchanged on exit.
18473 *
18474 * UPLO - CHARACTER*1.
18475 * On entry, UPLO specifies whether the upper or lower
18476 * triangular part of the symmetric matrix A is to be
18477 * referenced as follows:
18478 *
18479 * UPLO = 'U' or 'u' Only the upper triangular part of the
18480 * symmetric matrix is to be referenced.
18481 *
18482 * UPLO = 'L' or 'l' Only the lower triangular part of the
18483 * symmetric matrix is to be referenced.
18484 *
18485 * Unchanged on exit.
18486 *
18487 * M - INTEGER.
18488 * On entry, M specifies the number of rows of the matrix C.
18489 * M must be at least zero.
18490 * Unchanged on exit.
18491 *
18492 * N - INTEGER.
18493 * On entry, N specifies the number of columns of the matrix C.
18494 * N must be at least zero.
18495 * Unchanged on exit.
18496 *
18497 * ALPHA - REAL .
18498 * On entry, ALPHA specifies the scalar alpha.
18499 * Unchanged on exit.
18500 *
18501 * A - REAL array of DIMENSION ( LDA, ka ), where ka is
18502 * m when SIDE = 'L' or 'l' and is n otherwise.
18503 * Before entry with SIDE = 'L' or 'l', the m by m part of
18504 * the array A must contain the symmetric matrix, such that
18505 * when UPLO = 'U' or 'u', the leading m by m upper triangular
18506 * part of the array A must contain the upper triangular part
18507 * of the symmetric matrix and the strictly lower triangular
18508 * part of A is not referenced, and when UPLO = 'L' or 'l',
18509 * the leading m by m lower triangular part of the array A
18510 * must contain the lower triangular part of the symmetric
18511 * matrix and the strictly upper triangular part of A is not
18512 * referenced.
18513 * Before entry with SIDE = 'R' or 'r', the n by n part of
18514 * the array A must contain the symmetric matrix, such that
18515 * when UPLO = 'U' or 'u', the leading n by n upper triangular
18516 * part of the array A must contain the upper triangular part
18517 * of the symmetric matrix and the strictly lower triangular
18518 * part of A is not referenced, and when UPLO = 'L' or 'l',
18519 * the leading n by n lower triangular part of the array A
18520 * must contain the lower triangular part of the symmetric
18521 * matrix and the strictly upper triangular part of A is not
18522 * referenced.
18523 * Unchanged on exit.
18524 *
18525 * LDA - INTEGER.
18526 * On entry, LDA specifies the first dimension of A as declared
18527 * in the calling (sub) program. When SIDE = 'L' or 'l' then
18528 * LDA must be at least max( 1, m ), otherwise LDA must be at
18529 * least max( 1, n ).
18530 * Unchanged on exit.
18531 *
18532 * B - REAL array of DIMENSION ( LDB, n ).
18533 * Before entry, the leading m by n part of the array B must
18534 * contain the matrix B.
18535 * Unchanged on exit.
18536 *
18537 * LDB - INTEGER.
18538 * On entry, LDB specifies the first dimension of B as declared
18539 * in the calling (sub) program. LDB must be at least
18540 * max( 1, m ).
18541 * Unchanged on exit.
18542 *
18543 * BETA - REAL .
18544 * On entry, BETA specifies the scalar beta. When BETA is
18545 * supplied as zero then C need not be set on input.
18546 * Unchanged on exit.
18547 *
18548 * C - REAL array of DIMENSION ( LDC, n ).
18549 * Before entry, the leading m by n part of the array C must
18550 * contain the matrix C, except when beta is zero, in which
18551 * case C need not be set on entry.
18552 * On exit, the array C is overwritten by the m by n updated
18553 * matrix.
18554 *
18555 * LDC - INTEGER.
18556 * On entry, LDC specifies the first dimension of C as declared
18557 * in the calling (sub) program. LDC must be at least
18558 * max( 1, m ).
18559 * Unchanged on exit.
18560 *
18561 *
18562 * Level 3 Blas routine.
18563 *
18564 * -- Written on 8-February-1989.
18565 * Jack Dongarra, Argonne National Laboratory.
18566 * Iain Duff, AERE Harwell.
18567 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
18568 * Sven Hammarling, Numerical Algorithms Group Ltd.
18569 *
18570 *
18571 * .. External Functions ..
18572  LOGICAL LSAME
18573  EXTERNAL lsame
18574 * .. External Subroutines ..
18575  EXTERNAL xerbla
18576 * .. Intrinsic Functions ..
18577  INTRINSIC max
18578 * .. Local Scalars ..
18579  LOGICAL UPPER
18580  INTEGER I, INFO, J, K, NROWA
18581  REAL TEMP1, TEMP2
18582 * .. Parameters ..
18583  REAL ONE , ZERO
18584  parameter( one = 1.0e+0, zero = 0.0e+0 )
18585 * ..
18586 * .. Executable Statements ..
18587 *
18588 * Set NROWA as the number of rows of A.
18589 *
18590  IF( lsame( side, 'L' ) )THEN
18591  nrowa = m
18592  ELSE
18593  nrowa = n
18594  END IF
18595  upper = lsame( uplo, 'U' )
18596 *
18597 * Test the input parameters.
18598 *
18599  info = 0
18600  IF( ( .NOT.lsame( side, 'L' ) ).AND.
18601  $ ( .NOT.lsame( side, 'R' ) ) )THEN
18602  info = 1
18603  ELSE IF( ( .NOT.upper ).AND.
18604  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
18605  info = 2
18606  ELSE IF( m .LT.0 )THEN
18607  info = 3
18608  ELSE IF( n .LT.0 )THEN
18609  info = 4
18610  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
18611  info = 7
18612  ELSE IF( ldb.LT.max( 1, m ) )THEN
18613  info = 9
18614  ELSE IF( ldc.LT.max( 1, m ) )THEN
18615  info = 12
18616  END IF
18617  IF( info.NE.0 )THEN
18618  CALL xerbla( 'SSYMM ', info )
18619  RETURN
18620  END IF
18621 *
18622 * Quick return if possible.
18623 *
18624  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
18625  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
18626  $ RETURN
18627 *
18628 * And when alpha.eq.zero.
18629 *
18630  IF( alpha.EQ.zero )THEN
18631  IF( beta.EQ.zero )THEN
18632  DO 20, j = 1, n
18633  DO 10, i = 1, m
18634  c( i, j ) = zero
18635  10 CONTINUE
18636  20 CONTINUE
18637  ELSE
18638  DO 40, j = 1, n
18639  DO 30, i = 1, m
18640  c( i, j ) = beta*c( i, j )
18641  30 CONTINUE
18642  40 CONTINUE
18643  END IF
18644  RETURN
18645  END IF
18646 *
18647 * Start the operations.
18648 *
18649  IF( lsame( side, 'L' ) )THEN
18650 *
18651 * Form C := alpha*A*B + beta*C.
18652 *
18653  IF( upper )THEN
18654  DO 70, j = 1, n
18655  DO 60, i = 1, m
18656  temp1 = alpha*b( i, j )
18657  temp2 = zero
18658  DO 50, k = 1, i - 1
18659  c( k, j ) = c( k, j ) + temp1 *a( k, i )
18660  temp2 = temp2 + b( k, j )*a( k, i )
18661  50 CONTINUE
18662  IF( beta.EQ.zero )THEN
18663  c( i, j ) = temp1*a( i, i ) + alpha*temp2
18664  ELSE
18665  c( i, j ) = beta *c( i, j ) +
18666  $ temp1*a( i, i ) + alpha*temp2
18667  END IF
18668  60 CONTINUE
18669  70 CONTINUE
18670  ELSE
18671  DO 100, j = 1, n
18672  DO 90, i = m, 1, -1
18673  temp1 = alpha*b( i, j )
18674  temp2 = zero
18675  DO 80, k = i + 1, m
18676  c( k, j ) = c( k, j ) + temp1 *a( k, i )
18677  temp2 = temp2 + b( k, j )*a( k, i )
18678  80 CONTINUE
18679  IF( beta.EQ.zero )THEN
18680  c( i, j ) = temp1*a( i, i ) + alpha*temp2
18681  ELSE
18682  c( i, j ) = beta *c( i, j ) +
18683  $ temp1*a( i, i ) + alpha*temp2
18684  END IF
18685  90 CONTINUE
18686  100 CONTINUE
18687  END IF
18688  ELSE
18689 *
18690 * Form C := alpha*B*A + beta*C.
18691 *
18692  DO 170, j = 1, n
18693  temp1 = alpha*a( j, j )
18694  IF( beta.EQ.zero )THEN
18695  DO 110, i = 1, m
18696  c( i, j ) = temp1*b( i, j )
18697  110 CONTINUE
18698  ELSE
18699  DO 120, i = 1, m
18700  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
18701  120 CONTINUE
18702  END IF
18703  DO 140, k = 1, j - 1
18704  IF( upper )THEN
18705  temp1 = alpha*a( k, j )
18706  ELSE
18707  temp1 = alpha*a( j, k )
18708  END IF
18709  DO 130, i = 1, m
18710  c( i, j ) = c( i, j ) + temp1*b( i, k )
18711  130 CONTINUE
18712  140 CONTINUE
18713  DO 160, k = j + 1, n
18714  IF( upper )THEN
18715  temp1 = alpha*a( j, k )
18716  ELSE
18717  temp1 = alpha*a( k, j )
18718  END IF
18719  DO 150, i = 1, m
18720  c( i, j ) = c( i, j ) + temp1*b( i, k )
18721  150 CONTINUE
18722  160 CONTINUE
18723  170 CONTINUE
18724  END IF
18725 *
18726  RETURN
18727 *
18728 * End of SSYMM .
18729 *
18730  END
18731  SUBROUTINE ssymv ( UPLO, N, ALPHA, A, LDA, X, INCX,
18732  $ beta, y, incy )
18733 * .. Scalar Arguments ..
18734  REAL ALPHA, BETA
18735  INTEGER INCX, INCY, LDA, N
18736  CHARACTER*1 UPLO
18737 * .. Array Arguments ..
18738  REAL A( lda, * ), X( * ), Y( * )
18739 * ..
18740 *
18741 * Purpose
18742 * =======
18743 *
18744 * SSYMV performs the matrix-vector operation
18745 *
18746 * y := alpha*A*x + beta*y,
18747 *
18748 * where alpha and beta are scalars, x and y are n element vectors and
18749 * A is an n by n symmetric matrix.
18750 *
18751 * Parameters
18752 * ==========
18753 *
18754 * UPLO - CHARACTER*1.
18755 * On entry, UPLO specifies whether the upper or lower
18756 * triangular part of the array A is to be referenced as
18757 * follows:
18758 *
18759 * UPLO = 'U' or 'u' Only the upper triangular part of A
18760 * is to be referenced.
18761 *
18762 * UPLO = 'L' or 'l' Only the lower triangular part of A
18763 * is to be referenced.
18764 *
18765 * Unchanged on exit.
18766 *
18767 * N - INTEGER.
18768 * On entry, N specifies the order of the matrix A.
18769 * N must be at least zero.
18770 * Unchanged on exit.
18771 *
18772 * ALPHA - REAL .
18773 * On entry, ALPHA specifies the scalar alpha.
18774 * Unchanged on exit.
18775 *
18776 * A - REAL array of DIMENSION ( LDA, n ).
18777 * Before entry with UPLO = 'U' or 'u', the leading n by n
18778 * upper triangular part of the array A must contain the upper
18779 * triangular part of the symmetric matrix and the strictly
18780 * lower triangular part of A is not referenced.
18781 * Before entry with UPLO = 'L' or 'l', the leading n by n
18782 * lower triangular part of the array A must contain the lower
18783 * triangular part of the symmetric matrix and the strictly
18784 * upper triangular part of A is not referenced.
18785 * Unchanged on exit.
18786 *
18787 * LDA - INTEGER.
18788 * On entry, LDA specifies the first dimension of A as declared
18789 * in the calling (sub) program. LDA must be at least
18790 * max( 1, n ).
18791 * Unchanged on exit.
18792 *
18793 * X - REAL array of dimension at least
18794 * ( 1 + ( n - 1 )*abs( INCX ) ).
18795 * Before entry, the incremented array X must contain the n
18796 * element vector x.
18797 * Unchanged on exit.
18798 *
18799 * INCX - INTEGER.
18800 * On entry, INCX specifies the increment for the elements of
18801 * X. INCX must not be zero.
18802 * Unchanged on exit.
18803 *
18804 * BETA - REAL .
18805 * On entry, BETA specifies the scalar beta. When BETA is
18806 * supplied as zero then Y need not be set on input.
18807 * Unchanged on exit.
18808 *
18809 * Y - REAL array of dimension at least
18810 * ( 1 + ( n - 1 )*abs( INCY ) ).
18811 * Before entry, the incremented array Y must contain the n
18812 * element vector y. On exit, Y is overwritten by the updated
18813 * vector y.
18814 *
18815 * INCY - INTEGER.
18816 * On entry, INCY specifies the increment for the elements of
18817 * Y. INCY must not be zero.
18818 * Unchanged on exit.
18819 *
18820 *
18821 * Level 2 Blas routine.
18822 *
18823 * -- Written on 22-October-1986.
18824 * Jack Dongarra, Argonne National Lab.
18825 * Jeremy Du Croz, Nag Central Office.
18826 * Sven Hammarling, Nag Central Office.
18827 * Richard Hanson, Sandia National Labs.
18828 *
18829 *
18830 * .. Parameters ..
18831  REAL ONE , ZERO
18832  parameter( one = 1.0e+0, zero = 0.0e+0 )
18833 * .. Local Scalars ..
18834  REAL TEMP1, TEMP2
18835  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
18836 * .. External Functions ..
18837  LOGICAL LSAME
18838  EXTERNAL lsame
18839 * .. External Subroutines ..
18840  EXTERNAL xerbla
18841 * .. Intrinsic Functions ..
18842  INTRINSIC max
18843 * ..
18844 * .. Executable Statements ..
18845 *
18846 * Test the input parameters.
18847 *
18848  info = 0
18849  IF ( .NOT.lsame( uplo, 'U' ).AND.
18850  $ .NOT.lsame( uplo, 'L' ) )THEN
18851  info = 1
18852  ELSE IF( n.LT.0 )THEN
18853  info = 2
18854  ELSE IF( lda.LT.max( 1, n ) )THEN
18855  info = 5
18856  ELSE IF( incx.EQ.0 )THEN
18857  info = 7
18858  ELSE IF( incy.EQ.0 )THEN
18859  info = 10
18860  END IF
18861  IF( info.NE.0 )THEN
18862  CALL xerbla( 'SSYMV ', info )
18863  RETURN
18864  END IF
18865 *
18866 * Quick return if possible.
18867 *
18868  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
18869  $ RETURN
18870 *
18871 * Set up the start points in X and Y.
18872 *
18873  IF( incx.GT.0 )THEN
18874  kx = 1
18875  ELSE
18876  kx = 1 - ( n - 1 )*incx
18877  END IF
18878  IF( incy.GT.0 )THEN
18879  ky = 1
18880  ELSE
18881  ky = 1 - ( n - 1 )*incy
18882  END IF
18883 *
18884 * Start the operations. In this version the elements of A are
18885 * accessed sequentially with one pass through the triangular part
18886 * of A.
18887 *
18888 * First form y := beta*y.
18889 *
18890  IF( beta.NE.one )THEN
18891  IF( incy.EQ.1 )THEN
18892  IF( beta.EQ.zero )THEN
18893  DO 10, i = 1, n
18894  y( i ) = zero
18895  10 CONTINUE
18896  ELSE
18897  DO 20, i = 1, n
18898  y( i ) = beta*y( i )
18899  20 CONTINUE
18900  END IF
18901  ELSE
18902  iy = ky
18903  IF( beta.EQ.zero )THEN
18904  DO 30, i = 1, n
18905  y( iy ) = zero
18906  iy = iy + incy
18907  30 CONTINUE
18908  ELSE
18909  DO 40, i = 1, n
18910  y( iy ) = beta*y( iy )
18911  iy = iy + incy
18912  40 CONTINUE
18913  END IF
18914  END IF
18915  END IF
18916  IF( alpha.EQ.zero )
18917  $ RETURN
18918  IF( lsame( uplo, 'U' ) )THEN
18919 *
18920 * Form y when A is stored in upper triangle.
18921 *
18922  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
18923  DO 60, j = 1, n
18924  temp1 = alpha*x( j )
18925  temp2 = zero
18926  DO 50, i = 1, j - 1
18927  y( i ) = y( i ) + temp1*a( i, j )
18928  temp2 = temp2 + a( i, j )*x( i )
18929  50 CONTINUE
18930  y( j ) = y( j ) + temp1*a( j, j ) + alpha*temp2
18931  60 CONTINUE
18932  ELSE
18933  jx = kx
18934  jy = ky
18935  DO 80, j = 1, n
18936  temp1 = alpha*x( jx )
18937  temp2 = zero
18938  ix = kx
18939  iy = ky
18940  DO 70, i = 1, j - 1
18941  y( iy ) = y( iy ) + temp1*a( i, j )
18942  temp2 = temp2 + a( i, j )*x( ix )
18943  ix = ix + incx
18944  iy = iy + incy
18945  70 CONTINUE
18946  y( jy ) = y( jy ) + temp1*a( j, j ) + alpha*temp2
18947  jx = jx + incx
18948  jy = jy + incy
18949  80 CONTINUE
18950  END IF
18951  ELSE
18952 *
18953 * Form y when A is stored in lower triangle.
18954 *
18955  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
18956  DO 100, j = 1, n
18957  temp1 = alpha*x( j )
18958  temp2 = zero
18959  y( j ) = y( j ) + temp1*a( j, j )
18960  DO 90, i = j + 1, n
18961  y( i ) = y( i ) + temp1*a( i, j )
18962  temp2 = temp2 + a( i, j )*x( i )
18963  90 CONTINUE
18964  y( j ) = y( j ) + alpha*temp2
18965  100 CONTINUE
18966  ELSE
18967  jx = kx
18968  jy = ky
18969  DO 120, j = 1, n
18970  temp1 = alpha*x( jx )
18971  temp2 = zero
18972  y( jy ) = y( jy ) + temp1*a( j, j )
18973  ix = jx
18974  iy = jy
18975  DO 110, i = j + 1, n
18976  ix = ix + incx
18977  iy = iy + incy
18978  y( iy ) = y( iy ) + temp1*a( i, j )
18979  temp2 = temp2 + a( i, j )*x( ix )
18980  110 CONTINUE
18981  y( jy ) = y( jy ) + alpha*temp2
18982  jx = jx + incx
18983  jy = jy + incy
18984  120 CONTINUE
18985  END IF
18986  END IF
18987 *
18988  RETURN
18989 *
18990 * End of SSYMV .
18991 *
18992  END
18993  SUBROUTINE ssyr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
18994 * .. Scalar Arguments ..
18995  REAL ALPHA
18996  INTEGER INCX, INCY, LDA, N
18997  CHARACTER*1 UPLO
18998 * .. Array Arguments ..
18999  REAL A( lda, * ), X( * ), Y( * )
19000 * ..
19001 *
19002 * Purpose
19003 * =======
19004 *
19005 * SSYR2 performs the symmetric rank 2 operation
19006 *
19007 * A := alpha*x*y' + alpha*y*x' + A,
19008 *
19009 * where alpha is a scalar, x and y are n element vectors and A is an n
19010 * by n symmetric matrix.
19011 *
19012 * Parameters
19013 * ==========
19014 *
19015 * UPLO - CHARACTER*1.
19016 * On entry, UPLO specifies whether the upper or lower
19017 * triangular part of the array A is to be referenced as
19018 * follows:
19019 *
19020 * UPLO = 'U' or 'u' Only the upper triangular part of A
19021 * is to be referenced.
19022 *
19023 * UPLO = 'L' or 'l' Only the lower triangular part of A
19024 * is to be referenced.
19025 *
19026 * Unchanged on exit.
19027 *
19028 * N - INTEGER.
19029 * On entry, N specifies the order of the matrix A.
19030 * N must be at least zero.
19031 * Unchanged on exit.
19032 *
19033 * ALPHA - REAL .
19034 * On entry, ALPHA specifies the scalar alpha.
19035 * Unchanged on exit.
19036 *
19037 * X - REAL array of dimension at least
19038 * ( 1 + ( n - 1 )*abs( INCX ) ).
19039 * Before entry, the incremented array X must contain the n
19040 * element vector x.
19041 * Unchanged on exit.
19042 *
19043 * INCX - INTEGER.
19044 * On entry, INCX specifies the increment for the elements of
19045 * X. INCX must not be zero.
19046 * Unchanged on exit.
19047 *
19048 * Y - REAL array of dimension at least
19049 * ( 1 + ( n - 1 )*abs( INCY ) ).
19050 * Before entry, the incremented array Y must contain the n
19051 * element vector y.
19052 * Unchanged on exit.
19053 *
19054 * INCY - INTEGER.
19055 * On entry, INCY specifies the increment for the elements of
19056 * Y. INCY must not be zero.
19057 * Unchanged on exit.
19058 *
19059 * A - REAL array of DIMENSION ( LDA, n ).
19060 * Before entry with UPLO = 'U' or 'u', the leading n by n
19061 * upper triangular part of the array A must contain the upper
19062 * triangular part of the symmetric matrix and the strictly
19063 * lower triangular part of A is not referenced. On exit, the
19064 * upper triangular part of the array A is overwritten by the
19065 * upper triangular part of the updated matrix.
19066 * Before entry with UPLO = 'L' or 'l', the leading n by n
19067 * lower triangular part of the array A must contain the lower
19068 * triangular part of the symmetric matrix and the strictly
19069 * upper triangular part of A is not referenced. On exit, the
19070 * lower triangular part of the array A is overwritten by the
19071 * lower triangular part of the updated matrix.
19072 *
19073 * LDA - INTEGER.
19074 * On entry, LDA specifies the first dimension of A as declared
19075 * in the calling (sub) program. LDA must be at least
19076 * max( 1, n ).
19077 * Unchanged on exit.
19078 *
19079 *
19080 * Level 2 Blas routine.
19081 *
19082 * -- Written on 22-October-1986.
19083 * Jack Dongarra, Argonne National Lab.
19084 * Jeremy Du Croz, Nag Central Office.
19085 * Sven Hammarling, Nag Central Office.
19086 * Richard Hanson, Sandia National Labs.
19087 *
19088 *
19089 * .. Parameters ..
19090  REAL ZERO
19091  parameter( zero = 0.0e+0 )
19092 * .. Local Scalars ..
19093  REAL TEMP1, TEMP2
19094  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
19095 * .. External Functions ..
19096  LOGICAL LSAME
19097  EXTERNAL lsame
19098 * .. External Subroutines ..
19099  EXTERNAL xerbla
19100 * .. Intrinsic Functions ..
19101  INTRINSIC max
19102 * ..
19103 * .. Executable Statements ..
19104 *
19105 * Test the input parameters.
19106 *
19107  info = 0
19108  IF ( .NOT.lsame( uplo, 'U' ).AND.
19109  $ .NOT.lsame( uplo, 'L' ) )THEN
19110  info = 1
19111  ELSE IF( n.LT.0 )THEN
19112  info = 2
19113  ELSE IF( incx.EQ.0 )THEN
19114  info = 5
19115  ELSE IF( incy.EQ.0 )THEN
19116  info = 7
19117  ELSE IF( lda.LT.max( 1, n ) )THEN
19118  info = 9
19119  END IF
19120  IF( info.NE.0 )THEN
19121  CALL xerbla( 'SSYR2 ', info )
19122  RETURN
19123  END IF
19124 *
19125 * Quick return if possible.
19126 *
19127  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
19128  $ RETURN
19129 *
19130 * Set up the start points in X and Y if the increments are not both
19131 * unity.
19132 *
19133  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
19134  IF( incx.GT.0 )THEN
19135  kx = 1
19136  ELSE
19137  kx = 1 - ( n - 1 )*incx
19138  END IF
19139  IF( incy.GT.0 )THEN
19140  ky = 1
19141  ELSE
19142  ky = 1 - ( n - 1 )*incy
19143  END IF
19144  jx = kx
19145  jy = ky
19146  END IF
19147 *
19148 * Start the operations. In this version the elements of A are
19149 * accessed sequentially with one pass through the triangular part
19150 * of A.
19151 *
19152  IF( lsame( uplo, 'U' ) )THEN
19153 *
19154 * Form A when A is stored in the upper triangle.
19155 *
19156  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
19157  DO 20, j = 1, n
19158  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
19159  temp1 = alpha*y( j )
19160  temp2 = alpha*x( j )
19161  DO 10, i = 1, j
19162  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
19163  10 CONTINUE
19164  END IF
19165  20 CONTINUE
19166  ELSE
19167  DO 40, j = 1, n
19168  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
19169  temp1 = alpha*y( jy )
19170  temp2 = alpha*x( jx )
19171  ix = kx
19172  iy = ky
19173  DO 30, i = 1, j
19174  a( i, j ) = a( i, j ) + x( ix )*temp1
19175  $ + y( iy )*temp2
19176  ix = ix + incx
19177  iy = iy + incy
19178  30 CONTINUE
19179  END IF
19180  jx = jx + incx
19181  jy = jy + incy
19182  40 CONTINUE
19183  END IF
19184  ELSE
19185 *
19186 * Form A when A is stored in the lower triangle.
19187 *
19188  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
19189  DO 60, j = 1, n
19190  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
19191  temp1 = alpha*y( j )
19192  temp2 = alpha*x( j )
19193  DO 50, i = j, n
19194  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
19195  50 CONTINUE
19196  END IF
19197  60 CONTINUE
19198  ELSE
19199  DO 80, j = 1, n
19200  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
19201  temp1 = alpha*y( jy )
19202  temp2 = alpha*x( jx )
19203  ix = jx
19204  iy = jy
19205  DO 70, i = j, n
19206  a( i, j ) = a( i, j ) + x( ix )*temp1
19207  $ + y( iy )*temp2
19208  ix = ix + incx
19209  iy = iy + incy
19210  70 CONTINUE
19211  END IF
19212  jx = jx + incx
19213  jy = jy + incy
19214  80 CONTINUE
19215  END IF
19216  END IF
19217 *
19218  RETURN
19219 *
19220 * End of SSYR2 .
19221 *
19222  END
19223  SUBROUTINE ssyr2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
19224  $ beta, c, ldc )
19225 * .. Scalar Arguments ..
19226  CHARACTER*1 UPLO, TRANS
19227  INTEGER N, K, LDA, LDB, LDC
19228  REAL ALPHA, BETA
19229 * .. Array Arguments ..
19230  REAL A( lda, * ), B( ldb, * ), C( ldc, * )
19231 * ..
19232 *
19233 * Purpose
19234 * =======
19235 *
19236 * SSYR2K performs one of the symmetric rank 2k operations
19237 *
19238 * C := alpha*A*B' + alpha*B*A' + beta*C,
19239 *
19240 * or
19241 *
19242 * C := alpha*A'*B + alpha*B'*A + beta*C,
19243 *
19244 * where alpha and beta are scalars, C is an n by n symmetric matrix
19245 * and A and B are n by k matrices in the first case and k by n
19246 * matrices in the second case.
19247 *
19248 * Parameters
19249 * ==========
19250 *
19251 * UPLO - CHARACTER*1.
19252 * On entry, UPLO specifies whether the upper or lower
19253 * triangular part of the array C is to be referenced as
19254 * follows:
19255 *
19256 * UPLO = 'U' or 'u' Only the upper triangular part of C
19257 * is to be referenced.
19258 *
19259 * UPLO = 'L' or 'l' Only the lower triangular part of C
19260 * is to be referenced.
19261 *
19262 * Unchanged on exit.
19263 *
19264 * TRANS - CHARACTER*1.
19265 * On entry, TRANS specifies the operation to be performed as
19266 * follows:
19267 *
19268 * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
19269 * beta*C.
19270 *
19271 * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
19272 * beta*C.
19273 *
19274 * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
19275 * beta*C.
19276 *
19277 * Unchanged on exit.
19278 *
19279 * N - INTEGER.
19280 * On entry, N specifies the order of the matrix C. N must be
19281 * at least zero.
19282 * Unchanged on exit.
19283 *
19284 * K - INTEGER.
19285 * On entry with TRANS = 'N' or 'n', K specifies the number
19286 * of columns of the matrices A and B, and on entry with
19287 * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
19288 * of rows of the matrices A and B. K must be at least zero.
19289 * Unchanged on exit.
19290 *
19291 * ALPHA - REAL .
19292 * On entry, ALPHA specifies the scalar alpha.
19293 * Unchanged on exit.
19294 *
19295 * A - REAL array of DIMENSION ( LDA, ka ), where ka is
19296 * k when TRANS = 'N' or 'n', and is n otherwise.
19297 * Before entry with TRANS = 'N' or 'n', the leading n by k
19298 * part of the array A must contain the matrix A, otherwise
19299 * the leading k by n part of the array A must contain the
19300 * matrix A.
19301 * Unchanged on exit.
19302 *
19303 * LDA - INTEGER.
19304 * On entry, LDA specifies the first dimension of A as declared
19305 * in the calling (sub) program. When TRANS = 'N' or 'n'
19306 * then LDA must be at least max( 1, n ), otherwise LDA must
19307 * be at least max( 1, k ).
19308 * Unchanged on exit.
19309 *
19310 * B - REAL array of DIMENSION ( LDB, kb ), where kb is
19311 * k when TRANS = 'N' or 'n', and is n otherwise.
19312 * Before entry with TRANS = 'N' or 'n', the leading n by k
19313 * part of the array B must contain the matrix B, otherwise
19314 * the leading k by n part of the array B must contain the
19315 * matrix B.
19316 * Unchanged on exit.
19317 *
19318 * LDB - INTEGER.
19319 * On entry, LDB specifies the first dimension of B as declared
19320 * in the calling (sub) program. When TRANS = 'N' or 'n'
19321 * then LDB must be at least max( 1, n ), otherwise LDB must
19322 * be at least max( 1, k ).
19323 * Unchanged on exit.
19324 *
19325 * BETA - REAL .
19326 * On entry, BETA specifies the scalar beta.
19327 * Unchanged on exit.
19328 *
19329 * C - REAL array of DIMENSION ( LDC, n ).
19330 * Before entry with UPLO = 'U' or 'u', the leading n by n
19331 * upper triangular part of the array C must contain the upper
19332 * triangular part of the symmetric matrix and the strictly
19333 * lower triangular part of C is not referenced. On exit, the
19334 * upper triangular part of the array C is overwritten by the
19335 * upper triangular part of the updated matrix.
19336 * Before entry with UPLO = 'L' or 'l', the leading n by n
19337 * lower triangular part of the array C must contain the lower
19338 * triangular part of the symmetric matrix and the strictly
19339 * upper triangular part of C is not referenced. On exit, the
19340 * lower triangular part of the array C is overwritten by the
19341 * lower triangular part of the updated matrix.
19342 *
19343 * LDC - INTEGER.
19344 * On entry, LDC specifies the first dimension of C as declared
19345 * in the calling (sub) program. LDC must be at least
19346 * max( 1, n ).
19347 * Unchanged on exit.
19348 *
19349 *
19350 * Level 3 Blas routine.
19351 *
19352 *
19353 * -- Written on 8-February-1989.
19354 * Jack Dongarra, Argonne National Laboratory.
19355 * Iain Duff, AERE Harwell.
19356 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
19357 * Sven Hammarling, Numerical Algorithms Group Ltd.
19358 *
19359 *
19360 * .. External Functions ..
19361  LOGICAL LSAME
19362  EXTERNAL lsame
19363 * .. External Subroutines ..
19364  EXTERNAL xerbla
19365 * .. Intrinsic Functions ..
19366  INTRINSIC max
19367 * .. Local Scalars ..
19368  LOGICAL UPPER
19369  INTEGER I, INFO, J, L, NROWA
19370  REAL TEMP1, TEMP2
19371 * .. Parameters ..
19372  REAL ONE , ZERO
19373  parameter( one = 1.0e+0, zero = 0.0e+0 )
19374 * ..
19375 * .. Executable Statements ..
19376 *
19377 * Test the input parameters.
19378 *
19379  IF( lsame( trans, 'N' ) )THEN
19380  nrowa = n
19381  ELSE
19382  nrowa = k
19383  END IF
19384  upper = lsame( uplo, 'U' )
19385 *
19386  info = 0
19387  IF( ( .NOT.upper ).AND.
19388  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
19389  info = 1
19390  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
19391  $ ( .NOT.lsame( trans, 'T' ) ).AND.
19392  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
19393  info = 2
19394  ELSE IF( n .LT.0 )THEN
19395  info = 3
19396  ELSE IF( k .LT.0 )THEN
19397  info = 4
19398  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
19399  info = 7
19400  ELSE IF( ldb.LT.max( 1, nrowa ) )THEN
19401  info = 9
19402  ELSE IF( ldc.LT.max( 1, n ) )THEN
19403  info = 12
19404  END IF
19405  IF( info.NE.0 )THEN
19406  CALL xerbla( 'SSYR2K', info )
19407  RETURN
19408  END IF
19409 *
19410 * Quick return if possible.
19411 *
19412  IF( ( n.EQ.0 ).OR.
19413  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
19414  $ RETURN
19415 *
19416 * And when alpha.eq.zero.
19417 *
19418  IF( alpha.EQ.zero )THEN
19419  IF( upper )THEN
19420  IF( beta.EQ.zero )THEN
19421  DO 20, j = 1, n
19422  DO 10, i = 1, j
19423  c( i, j ) = zero
19424  10 CONTINUE
19425  20 CONTINUE
19426  ELSE
19427  DO 40, j = 1, n
19428  DO 30, i = 1, j
19429  c( i, j ) = beta*c( i, j )
19430  30 CONTINUE
19431  40 CONTINUE
19432  END IF
19433  ELSE
19434  IF( beta.EQ.zero )THEN
19435  DO 60, j = 1, n
19436  DO 50, i = j, n
19437  c( i, j ) = zero
19438  50 CONTINUE
19439  60 CONTINUE
19440  ELSE
19441  DO 80, j = 1, n
19442  DO 70, i = j, n
19443  c( i, j ) = beta*c( i, j )
19444  70 CONTINUE
19445  80 CONTINUE
19446  END IF
19447  END IF
19448  RETURN
19449  END IF
19450 *
19451 * Start the operations.
19452 *
19453  IF( lsame( trans, 'N' ) )THEN
19454 *
19455 * Form C := alpha*A*B' + alpha*B*A' + C.
19456 *
19457  IF( upper )THEN
19458  DO 130, j = 1, n
19459  IF( beta.EQ.zero )THEN
19460  DO 90, i = 1, j
19461  c( i, j ) = zero
19462  90 CONTINUE
19463  ELSE IF( beta.NE.one )THEN
19464  DO 100, i = 1, j
19465  c( i, j ) = beta*c( i, j )
19466  100 CONTINUE
19467  END IF
19468  DO 120, l = 1, k
19469  IF( ( a( j, l ).NE.zero ).OR.
19470  $ ( b( j, l ).NE.zero ) )THEN
19471  temp1 = alpha*b( j, l )
19472  temp2 = alpha*a( j, l )
19473  DO 110, i = 1, j
19474  c( i, j ) = c( i, j ) +
19475  $ a( i, l )*temp1 + b( i, l )*temp2
19476  110 CONTINUE
19477  END IF
19478  120 CONTINUE
19479  130 CONTINUE
19480  ELSE
19481  DO 180, j = 1, n
19482  IF( beta.EQ.zero )THEN
19483  DO 140, i = j, n
19484  c( i, j ) = zero
19485  140 CONTINUE
19486  ELSE IF( beta.NE.one )THEN
19487  DO 150, i = j, n
19488  c( i, j ) = beta*c( i, j )
19489  150 CONTINUE
19490  END IF
19491  DO 170, l = 1, k
19492  IF( ( a( j, l ).NE.zero ).OR.
19493  $ ( b( j, l ).NE.zero ) )THEN
19494  temp1 = alpha*b( j, l )
19495  temp2 = alpha*a( j, l )
19496  DO 160, i = j, n
19497  c( i, j ) = c( i, j ) +
19498  $ a( i, l )*temp1 + b( i, l )*temp2
19499  160 CONTINUE
19500  END IF
19501  170 CONTINUE
19502  180 CONTINUE
19503  END IF
19504  ELSE
19505 *
19506 * Form C := alpha*A'*B + alpha*B'*A + C.
19507 *
19508  IF( upper )THEN
19509  DO 210, j = 1, n
19510  DO 200, i = 1, j
19511  temp1 = zero
19512  temp2 = zero
19513  DO 190, l = 1, k
19514  temp1 = temp1 + a( l, i )*b( l, j )
19515  temp2 = temp2 + b( l, i )*a( l, j )
19516  190 CONTINUE
19517  IF( beta.EQ.zero )THEN
19518  c( i, j ) = alpha*temp1 + alpha*temp2
19519  ELSE
19520  c( i, j ) = beta *c( i, j ) +
19521  $ alpha*temp1 + alpha*temp2
19522  END IF
19523  200 CONTINUE
19524  210 CONTINUE
19525  ELSE
19526  DO 240, j = 1, n
19527  DO 230, i = j, n
19528  temp1 = zero
19529  temp2 = zero
19530  DO 220, l = 1, k
19531  temp1 = temp1 + a( l, i )*b( l, j )
19532  temp2 = temp2 + b( l, i )*a( l, j )
19533  220 CONTINUE
19534  IF( beta.EQ.zero )THEN
19535  c( i, j ) = alpha*temp1 + alpha*temp2
19536  ELSE
19537  c( i, j ) = beta *c( i, j ) +
19538  $ alpha*temp1 + alpha*temp2
19539  END IF
19540  230 CONTINUE
19541  240 CONTINUE
19542  END IF
19543  END IF
19544 *
19545  RETURN
19546 *
19547 * End of SSYR2K.
19548 *
19549  END
19550  SUBROUTINE ssyr ( UPLO, N, ALPHA, X, INCX, A, LDA )
19551 * .. Scalar Arguments ..
19552  REAL ALPHA
19553  INTEGER INCX, LDA, N
19554  CHARACTER*1 UPLO
19555 * .. Array Arguments ..
19556  REAL A( lda, * ), X( * )
19557 * ..
19558 *
19559 * Purpose
19560 * =======
19561 *
19562 * SSYR performs the symmetric rank 1 operation
19563 *
19564 * A := alpha*x*x' + A,
19565 *
19566 * where alpha is a real scalar, x is an n element vector and A is an
19567 * n by n symmetric matrix.
19568 *
19569 * Parameters
19570 * ==========
19571 *
19572 * UPLO - CHARACTER*1.
19573 * On entry, UPLO specifies whether the upper or lower
19574 * triangular part of the array A is to be referenced as
19575 * follows:
19576 *
19577 * UPLO = 'U' or 'u' Only the upper triangular part of A
19578 * is to be referenced.
19579 *
19580 * UPLO = 'L' or 'l' Only the lower triangular part of A
19581 * is to be referenced.
19582 *
19583 * Unchanged on exit.
19584 *
19585 * N - INTEGER.
19586 * On entry, N specifies the order of the matrix A.
19587 * N must be at least zero.
19588 * Unchanged on exit.
19589 *
19590 * ALPHA - REAL .
19591 * On entry, ALPHA specifies the scalar alpha.
19592 * Unchanged on exit.
19593 *
19594 * X - REAL array of dimension at least
19595 * ( 1 + ( n - 1 )*abs( INCX ) ).
19596 * Before entry, the incremented array X must contain the n
19597 * element vector x.
19598 * Unchanged on exit.
19599 *
19600 * INCX - INTEGER.
19601 * On entry, INCX specifies the increment for the elements of
19602 * X. INCX must not be zero.
19603 * Unchanged on exit.
19604 *
19605 * A - REAL array of DIMENSION ( LDA, n ).
19606 * Before entry with UPLO = 'U' or 'u', the leading n by n
19607 * upper triangular part of the array A must contain the upper
19608 * triangular part of the symmetric matrix and the strictly
19609 * lower triangular part of A is not referenced. On exit, the
19610 * upper triangular part of the array A is overwritten by the
19611 * upper triangular part of the updated matrix.
19612 * Before entry with UPLO = 'L' or 'l', the leading n by n
19613 * lower triangular part of the array A must contain the lower
19614 * triangular part of the symmetric matrix and the strictly
19615 * upper triangular part of A is not referenced. On exit, the
19616 * lower triangular part of the array A is overwritten by the
19617 * lower triangular part of the updated matrix.
19618 *
19619 * LDA - INTEGER.
19620 * On entry, LDA specifies the first dimension of A as declared
19621 * in the calling (sub) program. LDA must be at least
19622 * max( 1, n ).
19623 * Unchanged on exit.
19624 *
19625 *
19626 * Level 2 Blas routine.
19627 *
19628 * -- Written on 22-October-1986.
19629 * Jack Dongarra, Argonne National Lab.
19630 * Jeremy Du Croz, Nag Central Office.
19631 * Sven Hammarling, Nag Central Office.
19632 * Richard Hanson, Sandia National Labs.
19633 *
19634 *
19635 * .. Parameters ..
19636  REAL ZERO
19637  parameter( zero = 0.0e+0 )
19638 * .. Local Scalars ..
19639  REAL TEMP
19640  INTEGER I, INFO, IX, J, JX, KX
19641 * .. External Functions ..
19642  LOGICAL LSAME
19643  EXTERNAL lsame
19644 * .. External Subroutines ..
19645  EXTERNAL xerbla
19646 * .. Intrinsic Functions ..
19647  INTRINSIC max
19648 * ..
19649 * .. Executable Statements ..
19650 *
19651 * Test the input parameters.
19652 *
19653  info = 0
19654  IF ( .NOT.lsame( uplo, 'U' ).AND.
19655  $ .NOT.lsame( uplo, 'L' ) )THEN
19656  info = 1
19657  ELSE IF( n.LT.0 )THEN
19658  info = 2
19659  ELSE IF( incx.EQ.0 )THEN
19660  info = 5
19661  ELSE IF( lda.LT.max( 1, n ) )THEN
19662  info = 7
19663  END IF
19664  IF( info.NE.0 )THEN
19665  CALL xerbla( 'SSYR ', info )
19666  RETURN
19667  END IF
19668 *
19669 * Quick return if possible.
19670 *
19671  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
19672  $ RETURN
19673 *
19674 * Set the start point in X if the increment is not unity.
19675 *
19676  IF( incx.LE.0 )THEN
19677  kx = 1 - ( n - 1 )*incx
19678  ELSE IF( incx.NE.1 )THEN
19679  kx = 1
19680  END IF
19681 *
19682 * Start the operations. In this version the elements of A are
19683 * accessed sequentially with one pass through the triangular part
19684 * of A.
19685 *
19686  IF( lsame( uplo, 'U' ) )THEN
19687 *
19688 * Form A when A is stored in upper triangle.
19689 *
19690  IF( incx.EQ.1 )THEN
19691  DO 20, j = 1, n
19692  IF( x( j ).NE.zero )THEN
19693  temp = alpha*x( j )
19694  DO 10, i = 1, j
19695  a( i, j ) = a( i, j ) + x( i )*temp
19696  10 CONTINUE
19697  END IF
19698  20 CONTINUE
19699  ELSE
19700  jx = kx
19701  DO 40, j = 1, n
19702  IF( x( jx ).NE.zero )THEN
19703  temp = alpha*x( jx )
19704  ix = kx
19705  DO 30, i = 1, j
19706  a( i, j ) = a( i, j ) + x( ix )*temp
19707  ix = ix + incx
19708  30 CONTINUE
19709  END IF
19710  jx = jx + incx
19711  40 CONTINUE
19712  END IF
19713  ELSE
19714 *
19715 * Form A when A is stored in lower triangle.
19716 *
19717  IF( incx.EQ.1 )THEN
19718  DO 60, j = 1, n
19719  IF( x( j ).NE.zero )THEN
19720  temp = alpha*x( j )
19721  DO 50, i = j, n
19722  a( i, j ) = a( i, j ) + x( i )*temp
19723  50 CONTINUE
19724  END IF
19725  60 CONTINUE
19726  ELSE
19727  jx = kx
19728  DO 80, j = 1, n
19729  IF( x( jx ).NE.zero )THEN
19730  temp = alpha*x( jx )
19731  ix = jx
19732  DO 70, i = j, n
19733  a( i, j ) = a( i, j ) + x( ix )*temp
19734  ix = ix + incx
19735  70 CONTINUE
19736  END IF
19737  jx = jx + incx
19738  80 CONTINUE
19739  END IF
19740  END IF
19741 *
19742  RETURN
19743 *
19744 * End of SSYR .
19745 *
19746  END
19747  SUBROUTINE ssyrk ( UPLO, TRANS, N, K, ALPHA, A, LDA,
19748  $ beta, c, ldc )
19749 * .. Scalar Arguments ..
19750  CHARACTER*1 UPLO, TRANS
19751  INTEGER N, K, LDA, LDC
19752  REAL ALPHA, BETA
19753 * .. Array Arguments ..
19754  REAL A( lda, * ), C( ldc, * )
19755 * ..
19756 *
19757 * Purpose
19758 * =======
19759 *
19760 * SSYRK performs one of the symmetric rank k operations
19761 *
19762 * C := alpha*A*A' + beta*C,
19763 *
19764 * or
19765 *
19766 * C := alpha*A'*A + beta*C,
19767 *
19768 * where alpha and beta are scalars, C is an n by n symmetric matrix
19769 * and A is an n by k matrix in the first case and a k by n matrix
19770 * in the second case.
19771 *
19772 * Parameters
19773 * ==========
19774 *
19775 * UPLO - CHARACTER*1.
19776 * On entry, UPLO specifies whether the upper or lower
19777 * triangular part of the array C is to be referenced as
19778 * follows:
19779 *
19780 * UPLO = 'U' or 'u' Only the upper triangular part of C
19781 * is to be referenced.
19782 *
19783 * UPLO = 'L' or 'l' Only the lower triangular part of C
19784 * is to be referenced.
19785 *
19786 * Unchanged on exit.
19787 *
19788 * TRANS - CHARACTER*1.
19789 * On entry, TRANS specifies the operation to be performed as
19790 * follows:
19791 *
19792 * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
19793 *
19794 * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
19795 *
19796 * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
19797 *
19798 * Unchanged on exit.
19799 *
19800 * N - INTEGER.
19801 * On entry, N specifies the order of the matrix C. N must be
19802 * at least zero.
19803 * Unchanged on exit.
19804 *
19805 * K - INTEGER.
19806 * On entry with TRANS = 'N' or 'n', K specifies the number
19807 * of columns of the matrix A, and on entry with
19808 * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
19809 * of rows of the matrix A. K must be at least zero.
19810 * Unchanged on exit.
19811 *
19812 * ALPHA - REAL .
19813 * On entry, ALPHA specifies the scalar alpha.
19814 * Unchanged on exit.
19815 *
19816 * A - REAL array of DIMENSION ( LDA, ka ), where ka is
19817 * k when TRANS = 'N' or 'n', and is n otherwise.
19818 * Before entry with TRANS = 'N' or 'n', the leading n by k
19819 * part of the array A must contain the matrix A, otherwise
19820 * the leading k by n part of the array A must contain the
19821 * matrix A.
19822 * Unchanged on exit.
19823 *
19824 * LDA - INTEGER.
19825 * On entry, LDA specifies the first dimension of A as declared
19826 * in the calling (sub) program. When TRANS = 'N' or 'n'
19827 * then LDA must be at least max( 1, n ), otherwise LDA must
19828 * be at least max( 1, k ).
19829 * Unchanged on exit.
19830 *
19831 * BETA - REAL .
19832 * On entry, BETA specifies the scalar beta.
19833 * Unchanged on exit.
19834 *
19835 * C - REAL array of DIMENSION ( LDC, n ).
19836 * Before entry with UPLO = 'U' or 'u', the leading n by n
19837 * upper triangular part of the array C must contain the upper
19838 * triangular part of the symmetric matrix and the strictly
19839 * lower triangular part of C is not referenced. On exit, the
19840 * upper triangular part of the array C is overwritten by the
19841 * upper triangular part of the updated matrix.
19842 * Before entry with UPLO = 'L' or 'l', the leading n by n
19843 * lower triangular part of the array C must contain the lower
19844 * triangular part of the symmetric matrix and the strictly
19845 * upper triangular part of C is not referenced. On exit, the
19846 * lower triangular part of the array C is overwritten by the
19847 * lower triangular part of the updated matrix.
19848 *
19849 * LDC - INTEGER.
19850 * On entry, LDC specifies the first dimension of C as declared
19851 * in the calling (sub) program. LDC must be at least
19852 * max( 1, n ).
19853 * Unchanged on exit.
19854 *
19855 *
19856 * Level 3 Blas routine.
19857 *
19858 * -- Written on 8-February-1989.
19859 * Jack Dongarra, Argonne National Laboratory.
19860 * Iain Duff, AERE Harwell.
19861 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
19862 * Sven Hammarling, Numerical Algorithms Group Ltd.
19863 *
19864 *
19865 * .. External Functions ..
19866  LOGICAL LSAME
19867  EXTERNAL lsame
19868 * .. External Subroutines ..
19869  EXTERNAL xerbla
19870 * .. Intrinsic Functions ..
19871  INTRINSIC max
19872 * .. Local Scalars ..
19873  LOGICAL UPPER
19874  INTEGER I, INFO, J, L, NROWA
19875  REAL TEMP
19876 * .. Parameters ..
19877  REAL ONE , ZERO
19878  parameter( one = 1.0e+0, zero = 0.0e+0 )
19879 * ..
19880 * .. Executable Statements ..
19881 *
19882 * Test the input parameters.
19883 *
19884  IF( lsame( trans, 'N' ) )THEN
19885  nrowa = n
19886  ELSE
19887  nrowa = k
19888  END IF
19889  upper = lsame( uplo, 'U' )
19890 *
19891  info = 0
19892  IF( ( .NOT.upper ).AND.
19893  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
19894  info = 1
19895  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
19896  $ ( .NOT.lsame( trans, 'T' ) ).AND.
19897  $ ( .NOT.lsame( trans, 'C' ) ) )THEN
19898  info = 2
19899  ELSE IF( n .LT.0 )THEN
19900  info = 3
19901  ELSE IF( k .LT.0 )THEN
19902  info = 4
19903  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
19904  info = 7
19905  ELSE IF( ldc.LT.max( 1, n ) )THEN
19906  info = 10
19907  END IF
19908  IF( info.NE.0 )THEN
19909  CALL xerbla( 'SSYRK ', info )
19910  RETURN
19911  END IF
19912 *
19913 * Quick return if possible.
19914 *
19915  IF( ( n.EQ.0 ).OR.
19916  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
19917  $ RETURN
19918 *
19919 * And when alpha.eq.zero.
19920 *
19921  IF( alpha.EQ.zero )THEN
19922  IF( upper )THEN
19923  IF( beta.EQ.zero )THEN
19924  DO 20, j = 1, n
19925  DO 10, i = 1, j
19926  c( i, j ) = zero
19927  10 CONTINUE
19928  20 CONTINUE
19929  ELSE
19930  DO 40, j = 1, n
19931  DO 30, i = 1, j
19932  c( i, j ) = beta*c( i, j )
19933  30 CONTINUE
19934  40 CONTINUE
19935  END IF
19936  ELSE
19937  IF( beta.EQ.zero )THEN
19938  DO 60, j = 1, n
19939  DO 50, i = j, n
19940  c( i, j ) = zero
19941  50 CONTINUE
19942  60 CONTINUE
19943  ELSE
19944  DO 80, j = 1, n
19945  DO 70, i = j, n
19946  c( i, j ) = beta*c( i, j )
19947  70 CONTINUE
19948  80 CONTINUE
19949  END IF
19950  END IF
19951  RETURN
19952  END IF
19953 *
19954 * Start the operations.
19955 *
19956  IF( lsame( trans, 'N' ) )THEN
19957 *
19958 * Form C := alpha*A*A' + beta*C.
19959 *
19960  IF( upper )THEN
19961  DO 130, j = 1, n
19962  IF( beta.EQ.zero )THEN
19963  DO 90, i = 1, j
19964  c( i, j ) = zero
19965  90 CONTINUE
19966  ELSE IF( beta.NE.one )THEN
19967  DO 100, i = 1, j
19968  c( i, j ) = beta*c( i, j )
19969  100 CONTINUE
19970  END IF
19971  DO 120, l = 1, k
19972  IF( a( j, l ).NE.zero )THEN
19973  temp = alpha*a( j, l )
19974  DO 110, i = 1, j
19975  c( i, j ) = c( i, j ) + temp*a( i, l )
19976  110 CONTINUE
19977  END IF
19978  120 CONTINUE
19979  130 CONTINUE
19980  ELSE
19981  DO 180, j = 1, n
19982  IF( beta.EQ.zero )THEN
19983  DO 140, i = j, n
19984  c( i, j ) = zero
19985  140 CONTINUE
19986  ELSE IF( beta.NE.one )THEN
19987  DO 150, i = j, n
19988  c( i, j ) = beta*c( i, j )
19989  150 CONTINUE
19990  END IF
19991  DO 170, l = 1, k
19992  IF( a( j, l ).NE.zero )THEN
19993  temp = alpha*a( j, l )
19994  DO 160, i = j, n
19995  c( i, j ) = c( i, j ) + temp*a( i, l )
19996  160 CONTINUE
19997  END IF
19998  170 CONTINUE
19999  180 CONTINUE
20000  END IF
20001  ELSE
20002 *
20003 * Form C := alpha*A'*A + beta*C.
20004 *
20005  IF( upper )THEN
20006  DO 210, j = 1, n
20007  DO 200, i = 1, j
20008  temp = zero
20009  DO 190, l = 1, k
20010  temp = temp + a( l, i )*a( l, j )
20011  190 CONTINUE
20012  IF( beta.EQ.zero )THEN
20013  c( i, j ) = alpha*temp
20014  ELSE
20015  c( i, j ) = alpha*temp + beta*c( i, j )
20016  END IF
20017  200 CONTINUE
20018  210 CONTINUE
20019  ELSE
20020  DO 240, j = 1, n
20021  DO 230, i = j, n
20022  temp = zero
20023  DO 220, l = 1, k
20024  temp = temp + a( l, i )*a( l, j )
20025  220 CONTINUE
20026  IF( beta.EQ.zero )THEN
20027  c( i, j ) = alpha*temp
20028  ELSE
20029  c( i, j ) = alpha*temp + beta*c( i, j )
20030  END IF
20031  230 CONTINUE
20032  240 CONTINUE
20033  END IF
20034  END IF
20035 *
20036  RETURN
20037 *
20038 * End of SSYRK .
20039 *
20040  END
20041  SUBROUTINE stbmv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
20042 * .. Scalar Arguments ..
20043  INTEGER INCX, K, LDA, N
20044  CHARACTER*1 DIAG, TRANS, UPLO
20045 * .. Array Arguments ..
20046  REAL A( lda, * ), X( * )
20047 * ..
20048 *
20049 * Purpose
20050 * =======
20051 *
20052 * STBMV performs one of the matrix-vector operations
20053 *
20054 * x := A*x, or x := A'*x,
20055 *
20056 * where x is an n element vector and A is an n by n unit, or non-unit,
20057 * upper or lower triangular band matrix, with ( k + 1 ) diagonals.
20058 *
20059 * Parameters
20060 * ==========
20061 *
20062 * UPLO - CHARACTER*1.
20063 * On entry, UPLO specifies whether the matrix is an upper or
20064 * lower triangular matrix as follows:
20065 *
20066 * UPLO = 'U' or 'u' A is an upper triangular matrix.
20067 *
20068 * UPLO = 'L' or 'l' A is a lower triangular matrix.
20069 *
20070 * Unchanged on exit.
20071 *
20072 * TRANS - CHARACTER*1.
20073 * On entry, TRANS specifies the operation to be performed as
20074 * follows:
20075 *
20076 * TRANS = 'N' or 'n' x := A*x.
20077 *
20078 * TRANS = 'T' or 't' x := A'*x.
20079 *
20080 * TRANS = 'C' or 'c' x := A'*x.
20081 *
20082 * Unchanged on exit.
20083 *
20084 * DIAG - CHARACTER*1.
20085 * On entry, DIAG specifies whether or not A is unit
20086 * triangular as follows:
20087 *
20088 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
20089 *
20090 * DIAG = 'N' or 'n' A is not assumed to be unit
20091 * triangular.
20092 *
20093 * Unchanged on exit.
20094 *
20095 * N - INTEGER.
20096 * On entry, N specifies the order of the matrix A.
20097 * N must be at least zero.
20098 * Unchanged on exit.
20099 *
20100 * K - INTEGER.
20101 * On entry with UPLO = 'U' or 'u', K specifies the number of
20102 * super-diagonals of the matrix A.
20103 * On entry with UPLO = 'L' or 'l', K specifies the number of
20104 * sub-diagonals of the matrix A.
20105 * K must satisfy 0 .le. K.
20106 * Unchanged on exit.
20107 *
20108 * A - REAL array of DIMENSION ( LDA, n ).
20109 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
20110 * by n part of the array A must contain the upper triangular
20111 * band part of the matrix of coefficients, supplied column by
20112 * column, with the leading diagonal of the matrix in row
20113 * ( k + 1 ) of the array, the first super-diagonal starting at
20114 * position 2 in row k, and so on. The top left k by k triangle
20115 * of the array A is not referenced.
20116 * The following program segment will transfer an upper
20117 * triangular band matrix from conventional full matrix storage
20118 * to band storage:
20119 *
20120 * DO 20, J = 1, N
20121 * M = K + 1 - J
20122 * DO 10, I = MAX( 1, J - K ), J
20123 * A( M + I, J ) = matrix( I, J )
20124 * 10 CONTINUE
20125 * 20 CONTINUE
20126 *
20127 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
20128 * by n part of the array A must contain the lower triangular
20129 * band part of the matrix of coefficients, supplied column by
20130 * column, with the leading diagonal of the matrix in row 1 of
20131 * the array, the first sub-diagonal starting at position 1 in
20132 * row 2, and so on. The bottom right k by k triangle of the
20133 * array A is not referenced.
20134 * The following program segment will transfer a lower
20135 * triangular band matrix from conventional full matrix storage
20136 * to band storage:
20137 *
20138 * DO 20, J = 1, N
20139 * M = 1 - J
20140 * DO 10, I = J, MIN( N, J + K )
20141 * A( M + I, J ) = matrix( I, J )
20142 * 10 CONTINUE
20143 * 20 CONTINUE
20144 *
20145 * Note that when DIAG = 'U' or 'u' the elements of the array A
20146 * corresponding to the diagonal elements of the matrix are not
20147 * referenced, but are assumed to be unity.
20148 * Unchanged on exit.
20149 *
20150 * LDA - INTEGER.
20151 * On entry, LDA specifies the first dimension of A as declared
20152 * in the calling (sub) program. LDA must be at least
20153 * ( k + 1 ).
20154 * Unchanged on exit.
20155 *
20156 * X - REAL array of dimension at least
20157 * ( 1 + ( n - 1 )*abs( INCX ) ).
20158 * Before entry, the incremented array X must contain the n
20159 * element vector x. On exit, X is overwritten with the
20160 * tranformed vector x.
20161 *
20162 * INCX - INTEGER.
20163 * On entry, INCX specifies the increment for the elements of
20164 * X. INCX must not be zero.
20165 * Unchanged on exit.
20166 *
20167 *
20168 * Level 2 Blas routine.
20169 *
20170 * -- Written on 22-October-1986.
20171 * Jack Dongarra, Argonne National Lab.
20172 * Jeremy Du Croz, Nag Central Office.
20173 * Sven Hammarling, Nag Central Office.
20174 * Richard Hanson, Sandia National Labs.
20175 *
20176 *
20177 * .. Parameters ..
20178  REAL ZERO
20179  parameter( zero = 0.0e+0 )
20180 * .. Local Scalars ..
20181  REAL TEMP
20182  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
20183  LOGICAL NOUNIT
20184 * .. External Functions ..
20185  LOGICAL LSAME
20186  EXTERNAL lsame
20187 * .. External Subroutines ..
20188  EXTERNAL xerbla
20189 * .. Intrinsic Functions ..
20190  INTRINSIC max, min
20191 * ..
20192 * .. Executable Statements ..
20193 *
20194 * Test the input parameters.
20195 *
20196  info = 0
20197  IF ( .NOT.lsame( uplo , 'U' ).AND.
20198  $ .NOT.lsame( uplo , 'L' ) )THEN
20199  info = 1
20200  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
20201  $ .NOT.lsame( trans, 'T' ).AND.
20202  $ .NOT.lsame( trans, 'C' ) )THEN
20203  info = 2
20204  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
20205  $ .NOT.lsame( diag , 'N' ) )THEN
20206  info = 3
20207  ELSE IF( n.LT.0 )THEN
20208  info = 4
20209  ELSE IF( k.LT.0 )THEN
20210  info = 5
20211  ELSE IF( lda.LT.( k + 1 ) )THEN
20212  info = 7
20213  ELSE IF( incx.EQ.0 )THEN
20214  info = 9
20215  END IF
20216  IF( info.NE.0 )THEN
20217  CALL xerbla( 'STBMV ', info )
20218  RETURN
20219  END IF
20220 *
20221 * Quick return if possible.
20222 *
20223  IF( n.EQ.0 )
20224  $ RETURN
20225 *
20226  nounit = lsame( diag, 'N' )
20227 *
20228 * Set up the start point in X if the increment is not unity. This
20229 * will be ( N - 1 )*INCX too small for descending loops.
20230 *
20231  IF( incx.LE.0 )THEN
20232  kx = 1 - ( n - 1 )*incx
20233  ELSE IF( incx.NE.1 )THEN
20234  kx = 1
20235  END IF
20236 *
20237 * Start the operations. In this version the elements of A are
20238 * accessed sequentially with one pass through A.
20239 *
20240  IF( lsame( trans, 'N' ) )THEN
20241 *
20242 * Form x := A*x.
20243 *
20244  IF( lsame( uplo, 'U' ) )THEN
20245  kplus1 = k + 1
20246  IF( incx.EQ.1 )THEN
20247  DO 20, j = 1, n
20248  IF( x( j ).NE.zero )THEN
20249  temp = x( j )
20250  l = kplus1 - j
20251  DO 10, i = max( 1, j - k ), j - 1
20252  x( i ) = x( i ) + temp*a( l + i, j )
20253  10 CONTINUE
20254  IF( nounit )
20255  $ x( j ) = x( j )*a( kplus1, j )
20256  END IF
20257  20 CONTINUE
20258  ELSE
20259  jx = kx
20260  DO 40, j = 1, n
20261  IF( x( jx ).NE.zero )THEN
20262  temp = x( jx )
20263  ix = kx
20264  l = kplus1 - j
20265  DO 30, i = max( 1, j - k ), j - 1
20266  x( ix ) = x( ix ) + temp*a( l + i, j )
20267  ix = ix + incx
20268  30 CONTINUE
20269  IF( nounit )
20270  $ x( jx ) = x( jx )*a( kplus1, j )
20271  END IF
20272  jx = jx + incx
20273  IF( j.GT.k )
20274  $ kx = kx + incx
20275  40 CONTINUE
20276  END IF
20277  ELSE
20278  IF( incx.EQ.1 )THEN
20279  DO 60, j = n, 1, -1
20280  IF( x( j ).NE.zero )THEN
20281  temp = x( j )
20282  l = 1 - j
20283  DO 50, i = min( n, j + k ), j + 1, -1
20284  x( i ) = x( i ) + temp*a( l + i, j )
20285  50 CONTINUE
20286  IF( nounit )
20287  $ x( j ) = x( j )*a( 1, j )
20288  END IF
20289  60 CONTINUE
20290  ELSE
20291  kx = kx + ( n - 1 )*incx
20292  jx = kx
20293  DO 80, j = n, 1, -1
20294  IF( x( jx ).NE.zero )THEN
20295  temp = x( jx )
20296  ix = kx
20297  l = 1 - j
20298  DO 70, i = min( n, j + k ), j + 1, -1
20299  x( ix ) = x( ix ) + temp*a( l + i, j )
20300  ix = ix - incx
20301  70 CONTINUE
20302  IF( nounit )
20303  $ x( jx ) = x( jx )*a( 1, j )
20304  END IF
20305  jx = jx - incx
20306  IF( ( n - j ).GE.k )
20307  $ kx = kx - incx
20308  80 CONTINUE
20309  END IF
20310  END IF
20311  ELSE
20312 *
20313 * Form x := A'*x.
20314 *
20315  IF( lsame( uplo, 'U' ) )THEN
20316  kplus1 = k + 1
20317  IF( incx.EQ.1 )THEN
20318  DO 100, j = n, 1, -1
20319  temp = x( j )
20320  l = kplus1 - j
20321  IF( nounit )
20322  $ temp = temp*a( kplus1, j )
20323  DO 90, i = j - 1, max( 1, j - k ), -1
20324  temp = temp + a( l + i, j )*x( i )
20325  90 CONTINUE
20326  x( j ) = temp
20327  100 CONTINUE
20328  ELSE
20329  kx = kx + ( n - 1 )*incx
20330  jx = kx
20331  DO 120, j = n, 1, -1
20332  temp = x( jx )
20333  kx = kx - incx
20334  ix = kx
20335  l = kplus1 - j
20336  IF( nounit )
20337  $ temp = temp*a( kplus1, j )
20338  DO 110, i = j - 1, max( 1, j - k ), -1
20339  temp = temp + a( l + i, j )*x( ix )
20340  ix = ix - incx
20341  110 CONTINUE
20342  x( jx ) = temp
20343  jx = jx - incx
20344  120 CONTINUE
20345  END IF
20346  ELSE
20347  IF( incx.EQ.1 )THEN
20348  DO 140, j = 1, n
20349  temp = x( j )
20350  l = 1 - j
20351  IF( nounit )
20352  $ temp = temp*a( 1, j )
20353  DO 130, i = j + 1, min( n, j + k )
20354  temp = temp + a( l + i, j )*x( i )
20355  130 CONTINUE
20356  x( j ) = temp
20357  140 CONTINUE
20358  ELSE
20359  jx = kx
20360  DO 160, j = 1, n
20361  temp = x( jx )
20362  kx = kx + incx
20363  ix = kx
20364  l = 1 - j
20365  IF( nounit )
20366  $ temp = temp*a( 1, j )
20367  DO 150, i = j + 1, min( n, j + k )
20368  temp = temp + a( l + i, j )*x( ix )
20369  ix = ix + incx
20370  150 CONTINUE
20371  x( jx ) = temp
20372  jx = jx + incx
20373  160 CONTINUE
20374  END IF
20375  END IF
20376  END IF
20377 *
20378  RETURN
20379 *
20380 * End of STBMV .
20381 *
20382  END
20383  SUBROUTINE stbsv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
20384 * .. Scalar Arguments ..
20385  INTEGER INCX, K, LDA, N
20386  CHARACTER*1 DIAG, TRANS, UPLO
20387 * .. Array Arguments ..
20388  REAL A( lda, * ), X( * )
20389 * ..
20390 *
20391 * Purpose
20392 * =======
20393 *
20394 * STBSV solves one of the systems of equations
20395 *
20396 * A*x = b, or A'*x = b,
20397 *
20398 * where b and x are n element vectors and A is an n by n unit, or
20399 * non-unit, upper or lower triangular band matrix, with ( k + 1 )
20400 * diagonals.
20401 *
20402 * No test for singularity or near-singularity is included in this
20403 * routine. Such tests must be performed before calling this routine.
20404 *
20405 * Parameters
20406 * ==========
20407 *
20408 * UPLO - CHARACTER*1.
20409 * On entry, UPLO specifies whether the matrix is an upper or
20410 * lower triangular matrix as follows:
20411 *
20412 * UPLO = 'U' or 'u' A is an upper triangular matrix.
20413 *
20414 * UPLO = 'L' or 'l' A is a lower triangular matrix.
20415 *
20416 * Unchanged on exit.
20417 *
20418 * TRANS - CHARACTER*1.
20419 * On entry, TRANS specifies the equations to be solved as
20420 * follows:
20421 *
20422 * TRANS = 'N' or 'n' A*x = b.
20423 *
20424 * TRANS = 'T' or 't' A'*x = b.
20425 *
20426 * TRANS = 'C' or 'c' A'*x = b.
20427 *
20428 * Unchanged on exit.
20429 *
20430 * DIAG - CHARACTER*1.
20431 * On entry, DIAG specifies whether or not A is unit
20432 * triangular as follows:
20433 *
20434 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
20435 *
20436 * DIAG = 'N' or 'n' A is not assumed to be unit
20437 * triangular.
20438 *
20439 * Unchanged on exit.
20440 *
20441 * N - INTEGER.
20442 * On entry, N specifies the order of the matrix A.
20443 * N must be at least zero.
20444 * Unchanged on exit.
20445 *
20446 * K - INTEGER.
20447 * On entry with UPLO = 'U' or 'u', K specifies the number of
20448 * super-diagonals of the matrix A.
20449 * On entry with UPLO = 'L' or 'l', K specifies the number of
20450 * sub-diagonals of the matrix A.
20451 * K must satisfy 0 .le. K.
20452 * Unchanged on exit.
20453 *
20454 * A - REAL array of DIMENSION ( LDA, n ).
20455 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
20456 * by n part of the array A must contain the upper triangular
20457 * band part of the matrix of coefficients, supplied column by
20458 * column, with the leading diagonal of the matrix in row
20459 * ( k + 1 ) of the array, the first super-diagonal starting at
20460 * position 2 in row k, and so on. The top left k by k triangle
20461 * of the array A is not referenced.
20462 * The following program segment will transfer an upper
20463 * triangular band matrix from conventional full matrix storage
20464 * to band storage:
20465 *
20466 * DO 20, J = 1, N
20467 * M = K + 1 - J
20468 * DO 10, I = MAX( 1, J - K ), J
20469 * A( M + I, J ) = matrix( I, J )
20470 * 10 CONTINUE
20471 * 20 CONTINUE
20472 *
20473 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
20474 * by n part of the array A must contain the lower triangular
20475 * band part of the matrix of coefficients, supplied column by
20476 * column, with the leading diagonal of the matrix in row 1 of
20477 * the array, the first sub-diagonal starting at position 1 in
20478 * row 2, and so on. The bottom right k by k triangle of the
20479 * array A is not referenced.
20480 * The following program segment will transfer a lower
20481 * triangular band matrix from conventional full matrix storage
20482 * to band storage:
20483 *
20484 * DO 20, J = 1, N
20485 * M = 1 - J
20486 * DO 10, I = J, MIN( N, J + K )
20487 * A( M + I, J ) = matrix( I, J )
20488 * 10 CONTINUE
20489 * 20 CONTINUE
20490 *
20491 * Note that when DIAG = 'U' or 'u' the elements of the array A
20492 * corresponding to the diagonal elements of the matrix are not
20493 * referenced, but are assumed to be unity.
20494 * Unchanged on exit.
20495 *
20496 * LDA - INTEGER.
20497 * On entry, LDA specifies the first dimension of A as declared
20498 * in the calling (sub) program. LDA must be at least
20499 * ( k + 1 ).
20500 * Unchanged on exit.
20501 *
20502 * X - REAL array of dimension at least
20503 * ( 1 + ( n - 1 )*abs( INCX ) ).
20504 * Before entry, the incremented array X must contain the n
20505 * element right-hand side vector b. On exit, X is overwritten
20506 * with the solution vector x.
20507 *
20508 * INCX - INTEGER.
20509 * On entry, INCX specifies the increment for the elements of
20510 * X. INCX must not be zero.
20511 * Unchanged on exit.
20512 *
20513 *
20514 * Level 2 Blas routine.
20515 *
20516 * -- Written on 22-October-1986.
20517 * Jack Dongarra, Argonne National Lab.
20518 * Jeremy Du Croz, Nag Central Office.
20519 * Sven Hammarling, Nag Central Office.
20520 * Richard Hanson, Sandia National Labs.
20521 *
20522 *
20523 * .. Parameters ..
20524  REAL ZERO
20525  parameter( zero = 0.0e+0 )
20526 * .. Local Scalars ..
20527  REAL TEMP
20528  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
20529  LOGICAL NOUNIT
20530 * .. External Functions ..
20531  LOGICAL LSAME
20532  EXTERNAL lsame
20533 * .. External Subroutines ..
20534  EXTERNAL xerbla
20535 * .. Intrinsic Functions ..
20536  INTRINSIC max, min
20537 * ..
20538 * .. Executable Statements ..
20539 *
20540 * Test the input parameters.
20541 *
20542  info = 0
20543  IF ( .NOT.lsame( uplo , 'U' ).AND.
20544  $ .NOT.lsame( uplo , 'L' ) )THEN
20545  info = 1
20546  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
20547  $ .NOT.lsame( trans, 'T' ).AND.
20548  $ .NOT.lsame( trans, 'C' ) )THEN
20549  info = 2
20550  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
20551  $ .NOT.lsame( diag , 'N' ) )THEN
20552  info = 3
20553  ELSE IF( n.LT.0 )THEN
20554  info = 4
20555  ELSE IF( k.LT.0 )THEN
20556  info = 5
20557  ELSE IF( lda.LT.( k + 1 ) )THEN
20558  info = 7
20559  ELSE IF( incx.EQ.0 )THEN
20560  info = 9
20561  END IF
20562  IF( info.NE.0 )THEN
20563  CALL xerbla( 'STBSV ', info )
20564  RETURN
20565  END IF
20566 *
20567 * Quick return if possible.
20568 *
20569  IF( n.EQ.0 )
20570  $ RETURN
20571 *
20572  nounit = lsame( diag, 'N' )
20573 *
20574 * Set up the start point in X if the increment is not unity. This
20575 * will be ( N - 1 )*INCX too small for descending loops.
20576 *
20577  IF( incx.LE.0 )THEN
20578  kx = 1 - ( n - 1 )*incx
20579  ELSE IF( incx.NE.1 )THEN
20580  kx = 1
20581  END IF
20582 *
20583 * Start the operations. In this version the elements of A are
20584 * accessed by sequentially with one pass through A.
20585 *
20586  IF( lsame( trans, 'N' ) )THEN
20587 *
20588 * Form x := inv( A )*x.
20589 *
20590  IF( lsame( uplo, 'U' ) )THEN
20591  kplus1 = k + 1
20592  IF( incx.EQ.1 )THEN
20593  DO 20, j = n, 1, -1
20594  IF( x( j ).NE.zero )THEN
20595  l = kplus1 - j
20596  IF( nounit )
20597  $ x( j ) = x( j )/a( kplus1, j )
20598  temp = x( j )
20599  DO 10, i = j - 1, max( 1, j - k ), -1
20600  x( i ) = x( i ) - temp*a( l + i, j )
20601  10 CONTINUE
20602  END IF
20603  20 CONTINUE
20604  ELSE
20605  kx = kx + ( n - 1 )*incx
20606  jx = kx
20607  DO 40, j = n, 1, -1
20608  kx = kx - incx
20609  IF( x( jx ).NE.zero )THEN
20610  ix = kx
20611  l = kplus1 - j
20612  IF( nounit )
20613  $ x( jx ) = x( jx )/a( kplus1, j )
20614  temp = x( jx )
20615  DO 30, i = j - 1, max( 1, j - k ), -1
20616  x( ix ) = x( ix ) - temp*a( l + i, j )
20617  ix = ix - incx
20618  30 CONTINUE
20619  END IF
20620  jx = jx - incx
20621  40 CONTINUE
20622  END IF
20623  ELSE
20624  IF( incx.EQ.1 )THEN
20625  DO 60, j = 1, n
20626  IF( x( j ).NE.zero )THEN
20627  l = 1 - j
20628  IF( nounit )
20629  $ x( j ) = x( j )/a( 1, j )
20630  temp = x( j )
20631  DO 50, i = j + 1, min( n, j + k )
20632  x( i ) = x( i ) - temp*a( l + i, j )
20633  50 CONTINUE
20634  END IF
20635  60 CONTINUE
20636  ELSE
20637  jx = kx
20638  DO 80, j = 1, n
20639  kx = kx + incx
20640  IF( x( jx ).NE.zero )THEN
20641  ix = kx
20642  l = 1 - j
20643  IF( nounit )
20644  $ x( jx ) = x( jx )/a( 1, j )
20645  temp = x( jx )
20646  DO 70, i = j + 1, min( n, j + k )
20647  x( ix ) = x( ix ) - temp*a( l + i, j )
20648  ix = ix + incx
20649  70 CONTINUE
20650  END IF
20651  jx = jx + incx
20652  80 CONTINUE
20653  END IF
20654  END IF
20655  ELSE
20656 *
20657 * Form x := inv( A')*x.
20658 *
20659  IF( lsame( uplo, 'U' ) )THEN
20660  kplus1 = k + 1
20661  IF( incx.EQ.1 )THEN
20662  DO 100, j = 1, n
20663  temp = x( j )
20664  l = kplus1 - j
20665  DO 90, i = max( 1, j - k ), j - 1
20666  temp = temp - a( l + i, j )*x( i )
20667  90 CONTINUE
20668  IF( nounit )
20669  $ temp = temp/a( kplus1, j )
20670  x( j ) = temp
20671  100 CONTINUE
20672  ELSE
20673  jx = kx
20674  DO 120, j = 1, n
20675  temp = x( jx )
20676  ix = kx
20677  l = kplus1 - j
20678  DO 110, i = max( 1, j - k ), j - 1
20679  temp = temp - a( l + i, j )*x( ix )
20680  ix = ix + incx
20681  110 CONTINUE
20682  IF( nounit )
20683  $ temp = temp/a( kplus1, j )
20684  x( jx ) = temp
20685  jx = jx + incx
20686  IF( j.GT.k )
20687  $ kx = kx + incx
20688  120 CONTINUE
20689  END IF
20690  ELSE
20691  IF( incx.EQ.1 )THEN
20692  DO 140, j = n, 1, -1
20693  temp = x( j )
20694  l = 1 - j
20695  DO 130, i = min( n, j + k ), j + 1, -1
20696  temp = temp - a( l + i, j )*x( i )
20697  130 CONTINUE
20698  IF( nounit )
20699  $ temp = temp/a( 1, j )
20700  x( j ) = temp
20701  140 CONTINUE
20702  ELSE
20703  kx = kx + ( n - 1 )*incx
20704  jx = kx
20705  DO 160, j = n, 1, -1
20706  temp = x( jx )
20707  ix = kx
20708  l = 1 - j
20709  DO 150, i = min( n, j + k ), j + 1, -1
20710  temp = temp - a( l + i, j )*x( ix )
20711  ix = ix - incx
20712  150 CONTINUE
20713  IF( nounit )
20714  $ temp = temp/a( 1, j )
20715  x( jx ) = temp
20716  jx = jx - incx
20717  IF( ( n - j ).GE.k )
20718  $ kx = kx - incx
20719  160 CONTINUE
20720  END IF
20721  END IF
20722  END IF
20723 *
20724  RETURN
20725 *
20726 * End of STBSV .
20727 *
20728  END
20729  SUBROUTINE stpmv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
20730 * .. Scalar Arguments ..
20731  INTEGER INCX, N
20732  CHARACTER*1 DIAG, TRANS, UPLO
20733 * .. Array Arguments ..
20734  REAL AP( * ), X( * )
20735 * ..
20736 *
20737 * Purpose
20738 * =======
20739 *
20740 * STPMV performs one of the matrix-vector operations
20741 *
20742 * x := A*x, or x := A'*x,
20743 *
20744 * where x is an n element vector and A is an n by n unit, or non-unit,
20745 * upper or lower triangular matrix, supplied in packed form.
20746 *
20747 * Parameters
20748 * ==========
20749 *
20750 * UPLO - CHARACTER*1.
20751 * On entry, UPLO specifies whether the matrix is an upper or
20752 * lower triangular matrix as follows:
20753 *
20754 * UPLO = 'U' or 'u' A is an upper triangular matrix.
20755 *
20756 * UPLO = 'L' or 'l' A is a lower triangular matrix.
20757 *
20758 * Unchanged on exit.
20759 *
20760 * TRANS - CHARACTER*1.
20761 * On entry, TRANS specifies the operation to be performed as
20762 * follows:
20763 *
20764 * TRANS = 'N' or 'n' x := A*x.
20765 *
20766 * TRANS = 'T' or 't' x := A'*x.
20767 *
20768 * TRANS = 'C' or 'c' x := A'*x.
20769 *
20770 * Unchanged on exit.
20771 *
20772 * DIAG - CHARACTER*1.
20773 * On entry, DIAG specifies whether or not A is unit
20774 * triangular as follows:
20775 *
20776 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
20777 *
20778 * DIAG = 'N' or 'n' A is not assumed to be unit
20779 * triangular.
20780 *
20781 * Unchanged on exit.
20782 *
20783 * N - INTEGER.
20784 * On entry, N specifies the order of the matrix A.
20785 * N must be at least zero.
20786 * Unchanged on exit.
20787 *
20788 * AP - REAL array of DIMENSION at least
20789 * ( ( n*( n + 1 ) )/2 ).
20790 * Before entry with UPLO = 'U' or 'u', the array AP must
20791 * contain the upper triangular matrix packed sequentially,
20792 * column by column, so that AP( 1 ) contains a( 1, 1 ),
20793 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
20794 * respectively, and so on.
20795 * Before entry with UPLO = 'L' or 'l', the array AP must
20796 * contain the lower triangular matrix packed sequentially,
20797 * column by column, so that AP( 1 ) contains a( 1, 1 ),
20798 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
20799 * respectively, and so on.
20800 * Note that when DIAG = 'U' or 'u', the diagonal elements of
20801 * A are not referenced, but are assumed to be unity.
20802 * Unchanged on exit.
20803 *
20804 * X - REAL array of dimension at least
20805 * ( 1 + ( n - 1 )*abs( INCX ) ).
20806 * Before entry, the incremented array X must contain the n
20807 * element vector x. On exit, X is overwritten with the
20808 * tranformed vector x.
20809 *
20810 * INCX - INTEGER.
20811 * On entry, INCX specifies the increment for the elements of
20812 * X. INCX must not be zero.
20813 * Unchanged on exit.
20814 *
20815 *
20816 * Level 2 Blas routine.
20817 *
20818 * -- Written on 22-October-1986.
20819 * Jack Dongarra, Argonne National Lab.
20820 * Jeremy Du Croz, Nag Central Office.
20821 * Sven Hammarling, Nag Central Office.
20822 * Richard Hanson, Sandia National Labs.
20823 *
20824 *
20825 * .. Parameters ..
20826  REAL ZERO
20827  parameter( zero = 0.0e+0 )
20828 * .. Local Scalars ..
20829  REAL TEMP
20830  INTEGER I, INFO, IX, J, JX, K, KK, KX
20831  LOGICAL NOUNIT
20832 * .. External Functions ..
20833  LOGICAL LSAME
20834  EXTERNAL lsame
20835 * .. External Subroutines ..
20836  EXTERNAL xerbla
20837 * ..
20838 * .. Executable Statements ..
20839 *
20840 * Test the input parameters.
20841 *
20842  info = 0
20843  IF ( .NOT.lsame( uplo , 'U' ).AND.
20844  $ .NOT.lsame( uplo , 'L' ) )THEN
20845  info = 1
20846  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
20847  $ .NOT.lsame( trans, 'T' ).AND.
20848  $ .NOT.lsame( trans, 'C' ) )THEN
20849  info = 2
20850  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
20851  $ .NOT.lsame( diag , 'N' ) )THEN
20852  info = 3
20853  ELSE IF( n.LT.0 )THEN
20854  info = 4
20855  ELSE IF( incx.EQ.0 )THEN
20856  info = 7
20857  END IF
20858  IF( info.NE.0 )THEN
20859  CALL xerbla( 'STPMV ', info )
20860  RETURN
20861  END IF
20862 *
20863 * Quick return if possible.
20864 *
20865  IF( n.EQ.0 )
20866  $ RETURN
20867 *
20868  nounit = lsame( diag, 'N' )
20869 *
20870 * Set up the start point in X if the increment is not unity. This
20871 * will be ( N - 1 )*INCX too small for descending loops.
20872 *
20873  IF( incx.LE.0 )THEN
20874  kx = 1 - ( n - 1 )*incx
20875  ELSE IF( incx.NE.1 )THEN
20876  kx = 1
20877  END IF
20878 *
20879 * Start the operations. In this version the elements of AP are
20880 * accessed sequentially with one pass through AP.
20881 *
20882  IF( lsame( trans, 'N' ) )THEN
20883 *
20884 * Form x:= A*x.
20885 *
20886  IF( lsame( uplo, 'U' ) )THEN
20887  kk =1
20888  IF( incx.EQ.1 )THEN
20889  DO 20, j = 1, n
20890  IF( x( j ).NE.zero )THEN
20891  temp = x( j )
20892  k = kk
20893  DO 10, i = 1, j - 1
20894  x( i ) = x( i ) + temp*ap( k )
20895  k = k + 1
20896  10 CONTINUE
20897  IF( nounit )
20898  $ x( j ) = x( j )*ap( kk + j - 1 )
20899  END IF
20900  kk = kk + j
20901  20 CONTINUE
20902  ELSE
20903  jx = kx
20904  DO 40, j = 1, n
20905  IF( x( jx ).NE.zero )THEN
20906  temp = x( jx )
20907  ix = kx
20908  DO 30, k = kk, kk + j - 2
20909  x( ix ) = x( ix ) + temp*ap( k )
20910  ix = ix + incx
20911  30 CONTINUE
20912  IF( nounit )
20913  $ x( jx ) = x( jx )*ap( kk + j - 1 )
20914  END IF
20915  jx = jx + incx
20916  kk = kk + j
20917  40 CONTINUE
20918  END IF
20919  ELSE
20920  kk = ( n*( n + 1 ) )/2
20921  IF( incx.EQ.1 )THEN
20922  DO 60, j = n, 1, -1
20923  IF( x( j ).NE.zero )THEN
20924  temp = x( j )
20925  k = kk
20926  DO 50, i = n, j + 1, -1
20927  x( i ) = x( i ) + temp*ap( k )
20928  k = k - 1
20929  50 CONTINUE
20930  IF( nounit )
20931  $ x( j ) = x( j )*ap( kk - n + j )
20932  END IF
20933  kk = kk - ( n - j + 1 )
20934  60 CONTINUE
20935  ELSE
20936  kx = kx + ( n - 1 )*incx
20937  jx = kx
20938  DO 80, j = n, 1, -1
20939  IF( x( jx ).NE.zero )THEN
20940  temp = x( jx )
20941  ix = kx
20942  DO 70, k = kk, kk - ( n - ( j + 1 ) ), -1
20943  x( ix ) = x( ix ) + temp*ap( k )
20944  ix = ix - incx
20945  70 CONTINUE
20946  IF( nounit )
20947  $ x( jx ) = x( jx )*ap( kk - n + j )
20948  END IF
20949  jx = jx - incx
20950  kk = kk - ( n - j + 1 )
20951  80 CONTINUE
20952  END IF
20953  END IF
20954  ELSE
20955 *
20956 * Form x := A'*x.
20957 *
20958  IF( lsame( uplo, 'U' ) )THEN
20959  kk = ( n*( n + 1 ) )/2
20960  IF( incx.EQ.1 )THEN
20961  DO 100, j = n, 1, -1
20962  temp = x( j )
20963  IF( nounit )
20964  $ temp = temp*ap( kk )
20965  k = kk - 1
20966  DO 90, i = j - 1, 1, -1
20967  temp = temp + ap( k )*x( i )
20968  k = k - 1
20969  90 CONTINUE
20970  x( j ) = temp
20971  kk = kk - j
20972  100 CONTINUE
20973  ELSE
20974  jx = kx + ( n - 1 )*incx
20975  DO 120, j = n, 1, -1
20976  temp = x( jx )
20977  ix = jx
20978  IF( nounit )
20979  $ temp = temp*ap( kk )
20980  DO 110, k = kk - 1, kk - j + 1, -1
20981  ix = ix - incx
20982  temp = temp + ap( k )*x( ix )
20983  110 CONTINUE
20984  x( jx ) = temp
20985  jx = jx - incx
20986  kk = kk - j
20987  120 CONTINUE
20988  END IF
20989  ELSE
20990  kk = 1
20991  IF( incx.EQ.1 )THEN
20992  DO 140, j = 1, n
20993  temp = x( j )
20994  IF( nounit )
20995  $ temp = temp*ap( kk )
20996  k = kk + 1
20997  DO 130, i = j + 1, n
20998  temp = temp + ap( k )*x( i )
20999  k = k + 1
21000  130 CONTINUE
21001  x( j ) = temp
21002  kk = kk + ( n - j + 1 )
21003  140 CONTINUE
21004  ELSE
21005  jx = kx
21006  DO 160, j = 1, n
21007  temp = x( jx )
21008  ix = jx
21009  IF( nounit )
21010  $ temp = temp*ap( kk )
21011  DO 150, k = kk + 1, kk + n - j
21012  ix = ix + incx
21013  temp = temp + ap( k )*x( ix )
21014  150 CONTINUE
21015  x( jx ) = temp
21016  jx = jx + incx
21017  kk = kk + ( n - j + 1 )
21018  160 CONTINUE
21019  END IF
21020  END IF
21021  END IF
21022 *
21023  RETURN
21024 *
21025 * End of STPMV .
21026 *
21027  END
21028  SUBROUTINE stpsv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
21029 * .. Scalar Arguments ..
21030  INTEGER INCX, N
21031  CHARACTER*1 DIAG, TRANS, UPLO
21032 * .. Array Arguments ..
21033  REAL AP( * ), X( * )
21034 * ..
21035 *
21036 * Purpose
21037 * =======
21038 *
21039 * STPSV solves one of the systems of equations
21040 *
21041 * A*x = b, or A'*x = b,
21042 *
21043 * where b and x are n element vectors and A is an n by n unit, or
21044 * non-unit, upper or lower triangular matrix, supplied in packed form.
21045 *
21046 * No test for singularity or near-singularity is included in this
21047 * routine. Such tests must be performed before calling this routine.
21048 *
21049 * Parameters
21050 * ==========
21051 *
21052 * UPLO - CHARACTER*1.
21053 * On entry, UPLO specifies whether the matrix is an upper or
21054 * lower triangular matrix as follows:
21055 *
21056 * UPLO = 'U' or 'u' A is an upper triangular matrix.
21057 *
21058 * UPLO = 'L' or 'l' A is a lower triangular matrix.
21059 *
21060 * Unchanged on exit.
21061 *
21062 * TRANS - CHARACTER*1.
21063 * On entry, TRANS specifies the equations to be solved as
21064 * follows:
21065 *
21066 * TRANS = 'N' or 'n' A*x = b.
21067 *
21068 * TRANS = 'T' or 't' A'*x = b.
21069 *
21070 * TRANS = 'C' or 'c' A'*x = b.
21071 *
21072 * Unchanged on exit.
21073 *
21074 * DIAG - CHARACTER*1.
21075 * On entry, DIAG specifies whether or not A is unit
21076 * triangular as follows:
21077 *
21078 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
21079 *
21080 * DIAG = 'N' or 'n' A is not assumed to be unit
21081 * triangular.
21082 *
21083 * Unchanged on exit.
21084 *
21085 * N - INTEGER.
21086 * On entry, N specifies the order of the matrix A.
21087 * N must be at least zero.
21088 * Unchanged on exit.
21089 *
21090 * AP - REAL array of DIMENSION at least
21091 * ( ( n*( n + 1 ) )/2 ).
21092 * Before entry with UPLO = 'U' or 'u', the array AP must
21093 * contain the upper triangular matrix packed sequentially,
21094 * column by column, so that AP( 1 ) contains a( 1, 1 ),
21095 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
21096 * respectively, and so on.
21097 * Before entry with UPLO = 'L' or 'l', the array AP must
21098 * contain the lower triangular matrix packed sequentially,
21099 * column by column, so that AP( 1 ) contains a( 1, 1 ),
21100 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
21101 * respectively, and so on.
21102 * Note that when DIAG = 'U' or 'u', the diagonal elements of
21103 * A are not referenced, but are assumed to be unity.
21104 * Unchanged on exit.
21105 *
21106 * X - REAL array of dimension at least
21107 * ( 1 + ( n - 1 )*abs( INCX ) ).
21108 * Before entry, the incremented array X must contain the n
21109 * element right-hand side vector b. On exit, X is overwritten
21110 * with the solution vector x.
21111 *
21112 * INCX - INTEGER.
21113 * On entry, INCX specifies the increment for the elements of
21114 * X. INCX must not be zero.
21115 * Unchanged on exit.
21116 *
21117 *
21118 * Level 2 Blas routine.
21119 *
21120 * -- Written on 22-October-1986.
21121 * Jack Dongarra, Argonne National Lab.
21122 * Jeremy Du Croz, Nag Central Office.
21123 * Sven Hammarling, Nag Central Office.
21124 * Richard Hanson, Sandia National Labs.
21125 *
21126 *
21127 * .. Parameters ..
21128  REAL ZERO
21129  parameter( zero = 0.0e+0 )
21130 * .. Local Scalars ..
21131  REAL TEMP
21132  INTEGER I, INFO, IX, J, JX, K, KK, KX
21133  LOGICAL NOUNIT
21134 * .. External Functions ..
21135  LOGICAL LSAME
21136  EXTERNAL lsame
21137 * .. External Subroutines ..
21138  EXTERNAL xerbla
21139 * ..
21140 * .. Executable Statements ..
21141 *
21142 * Test the input parameters.
21143 *
21144  info = 0
21145  IF ( .NOT.lsame( uplo , 'U' ).AND.
21146  $ .NOT.lsame( uplo , 'L' ) )THEN
21147  info = 1
21148  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
21149  $ .NOT.lsame( trans, 'T' ).AND.
21150  $ .NOT.lsame( trans, 'C' ) )THEN
21151  info = 2
21152  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
21153  $ .NOT.lsame( diag , 'N' ) )THEN
21154  info = 3
21155  ELSE IF( n.LT.0 )THEN
21156  info = 4
21157  ELSE IF( incx.EQ.0 )THEN
21158  info = 7
21159  END IF
21160  IF( info.NE.0 )THEN
21161  CALL xerbla( 'STPSV ', info )
21162  RETURN
21163  END IF
21164 *
21165 * Quick return if possible.
21166 *
21167  IF( n.EQ.0 )
21168  $ RETURN
21169 *
21170  nounit = lsame( diag, 'N' )
21171 *
21172 * Set up the start point in X if the increment is not unity. This
21173 * will be ( N - 1 )*INCX too small for descending loops.
21174 *
21175  IF( incx.LE.0 )THEN
21176  kx = 1 - ( n - 1 )*incx
21177  ELSE IF( incx.NE.1 )THEN
21178  kx = 1
21179  END IF
21180 *
21181 * Start the operations. In this version the elements of AP are
21182 * accessed sequentially with one pass through AP.
21183 *
21184  IF( lsame( trans, 'N' ) )THEN
21185 *
21186 * Form x := inv( A )*x.
21187 *
21188  IF( lsame( uplo, 'U' ) )THEN
21189  kk = ( n*( n + 1 ) )/2
21190  IF( incx.EQ.1 )THEN
21191  DO 20, j = n, 1, -1
21192  IF( x( j ).NE.zero )THEN
21193  IF( nounit )
21194  $ x( j ) = x( j )/ap( kk )
21195  temp = x( j )
21196  k = kk - 1
21197  DO 10, i = j - 1, 1, -1
21198  x( i ) = x( i ) - temp*ap( k )
21199  k = k - 1
21200  10 CONTINUE
21201  END IF
21202  kk = kk - j
21203  20 CONTINUE
21204  ELSE
21205  jx = kx + ( n - 1 )*incx
21206  DO 40, j = n, 1, -1
21207  IF( x( jx ).NE.zero )THEN
21208  IF( nounit )
21209  $ x( jx ) = x( jx )/ap( kk )
21210  temp = x( jx )
21211  ix = jx
21212  DO 30, k = kk - 1, kk - j + 1, -1
21213  ix = ix - incx
21214  x( ix ) = x( ix ) - temp*ap( k )
21215  30 CONTINUE
21216  END IF
21217  jx = jx - incx
21218  kk = kk - j
21219  40 CONTINUE
21220  END IF
21221  ELSE
21222  kk = 1
21223  IF( incx.EQ.1 )THEN
21224  DO 60, j = 1, n
21225  IF( x( j ).NE.zero )THEN
21226  IF( nounit )
21227  $ x( j ) = x( j )/ap( kk )
21228  temp = x( j )
21229  k = kk + 1
21230  DO 50, i = j + 1, n
21231  x( i ) = x( i ) - temp*ap( k )
21232  k = k + 1
21233  50 CONTINUE
21234  END IF
21235  kk = kk + ( n - j + 1 )
21236  60 CONTINUE
21237  ELSE
21238  jx = kx
21239  DO 80, j = 1, n
21240  IF( x( jx ).NE.zero )THEN
21241  IF( nounit )
21242  $ x( jx ) = x( jx )/ap( kk )
21243  temp = x( jx )
21244  ix = jx
21245  DO 70, k = kk + 1, kk + n - j
21246  ix = ix + incx
21247  x( ix ) = x( ix ) - temp*ap( k )
21248  70 CONTINUE
21249  END IF
21250  jx = jx + incx
21251  kk = kk + ( n - j + 1 )
21252  80 CONTINUE
21253  END IF
21254  END IF
21255  ELSE
21256 *
21257 * Form x := inv( A' )*x.
21258 *
21259  IF( lsame( uplo, 'U' ) )THEN
21260  kk = 1
21261  IF( incx.EQ.1 )THEN
21262  DO 100, j = 1, n
21263  temp = x( j )
21264  k = kk
21265  DO 90, i = 1, j - 1
21266  temp = temp - ap( k )*x( i )
21267  k = k + 1
21268  90 CONTINUE
21269  IF( nounit )
21270  $ temp = temp/ap( kk + j - 1 )
21271  x( j ) = temp
21272  kk = kk + j
21273  100 CONTINUE
21274  ELSE
21275  jx = kx
21276  DO 120, j = 1, n
21277  temp = x( jx )
21278  ix = kx
21279  DO 110, k = kk, kk + j - 2
21280  temp = temp - ap( k )*x( ix )
21281  ix = ix + incx
21282  110 CONTINUE
21283  IF( nounit )
21284  $ temp = temp/ap( kk + j - 1 )
21285  x( jx ) = temp
21286  jx = jx + incx
21287  kk = kk + j
21288  120 CONTINUE
21289  END IF
21290  ELSE
21291  kk = ( n*( n + 1 ) )/2
21292  IF( incx.EQ.1 )THEN
21293  DO 140, j = n, 1, -1
21294  temp = x( j )
21295  k = kk
21296  DO 130, i = n, j + 1, -1
21297  temp = temp - ap( k )*x( i )
21298  k = k - 1
21299  130 CONTINUE
21300  IF( nounit )
21301  $ temp = temp/ap( kk - n + j )
21302  x( j ) = temp
21303  kk = kk - ( n - j + 1 )
21304  140 CONTINUE
21305  ELSE
21306  kx = kx + ( n - 1 )*incx
21307  jx = kx
21308  DO 160, j = n, 1, -1
21309  temp = x( jx )
21310  ix = kx
21311  DO 150, k = kk, kk - ( n - ( j + 1 ) ), -1
21312  temp = temp - ap( k )*x( ix )
21313  ix = ix - incx
21314  150 CONTINUE
21315  IF( nounit )
21316  $ temp = temp/ap( kk - n + j )
21317  x( jx ) = temp
21318  jx = jx - incx
21319  kk = kk - (n - j + 1 )
21320  160 CONTINUE
21321  END IF
21322  END IF
21323  END IF
21324 *
21325  RETURN
21326 *
21327 * End of STPSV .
21328 *
21329  END
21330  SUBROUTINE strmm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
21331  $ b, ldb )
21332 * .. Scalar Arguments ..
21333  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
21334  INTEGER M, N, LDA, LDB
21335  REAL ALPHA
21336 * .. Array Arguments ..
21337  REAL A( lda, * ), B( ldb, * )
21338 * ..
21339 *
21340 * Purpose
21341 * =======
21342 *
21343 * STRMM performs one of the matrix-matrix operations
21344 *
21345 * B := alpha*op( A )*B, or B := alpha*B*op( A ),
21346 *
21347 * where alpha is a scalar, B is an m by n matrix, A is a unit, or
21348 * non-unit, upper or lower triangular matrix and op( A ) is one of
21349 *
21350 * op( A ) = A or op( A ) = A'.
21351 *
21352 * Parameters
21353 * ==========
21354 *
21355 * SIDE - CHARACTER*1.
21356 * On entry, SIDE specifies whether op( A ) multiplies B from
21357 * the left or right as follows:
21358 *
21359 * SIDE = 'L' or 'l' B := alpha*op( A )*B.
21360 *
21361 * SIDE = 'R' or 'r' B := alpha*B*op( A ).
21362 *
21363 * Unchanged on exit.
21364 *
21365 * UPLO - CHARACTER*1.
21366 * On entry, UPLO specifies whether the matrix A is an upper or
21367 * lower triangular matrix as follows:
21368 *
21369 * UPLO = 'U' or 'u' A is an upper triangular matrix.
21370 *
21371 * UPLO = 'L' or 'l' A is a lower triangular matrix.
21372 *
21373 * Unchanged on exit.
21374 *
21375 * TRANSA - CHARACTER*1.
21376 * On entry, TRANSA specifies the form of op( A ) to be used in
21377 * the matrix multiplication as follows:
21378 *
21379 * TRANSA = 'N' or 'n' op( A ) = A.
21380 *
21381 * TRANSA = 'T' or 't' op( A ) = A'.
21382 *
21383 * TRANSA = 'C' or 'c' op( A ) = A'.
21384 *
21385 * Unchanged on exit.
21386 *
21387 * DIAG - CHARACTER*1.
21388 * On entry, DIAG specifies whether or not A is unit triangular
21389 * as follows:
21390 *
21391 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
21392 *
21393 * DIAG = 'N' or 'n' A is not assumed to be unit
21394 * triangular.
21395 *
21396 * Unchanged on exit.
21397 *
21398 * M - INTEGER.
21399 * On entry, M specifies the number of rows of B. M must be at
21400 * least zero.
21401 * Unchanged on exit.
21402 *
21403 * N - INTEGER.
21404 * On entry, N specifies the number of columns of B. N must be
21405 * at least zero.
21406 * Unchanged on exit.
21407 *
21408 * ALPHA - REAL .
21409 * On entry, ALPHA specifies the scalar alpha. When alpha is
21410 * zero then A is not referenced and B need not be set before
21411 * entry.
21412 * Unchanged on exit.
21413 *
21414 * A - REAL array of DIMENSION ( LDA, k ), where k is m
21415 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
21416 * Before entry with UPLO = 'U' or 'u', the leading k by k
21417 * upper triangular part of the array A must contain the upper
21418 * triangular matrix and the strictly lower triangular part of
21419 * A is not referenced.
21420 * Before entry with UPLO = 'L' or 'l', the leading k by k
21421 * lower triangular part of the array A must contain the lower
21422 * triangular matrix and the strictly upper triangular part of
21423 * A is not referenced.
21424 * Note that when DIAG = 'U' or 'u', the diagonal elements of
21425 * A are not referenced either, but are assumed to be unity.
21426 * Unchanged on exit.
21427 *
21428 * LDA - INTEGER.
21429 * On entry, LDA specifies the first dimension of A as declared
21430 * in the calling (sub) program. When SIDE = 'L' or 'l' then
21431 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
21432 * then LDA must be at least max( 1, n ).
21433 * Unchanged on exit.
21434 *
21435 * B - REAL array of DIMENSION ( LDB, n ).
21436 * Before entry, the leading m by n part of the array B must
21437 * contain the matrix B, and on exit is overwritten by the
21438 * transformed matrix.
21439 *
21440 * LDB - INTEGER.
21441 * On entry, LDB specifies the first dimension of B as declared
21442 * in the calling (sub) program. LDB must be at least
21443 * max( 1, m ).
21444 * Unchanged on exit.
21445 *
21446 *
21447 * Level 3 Blas routine.
21448 *
21449 * -- Written on 8-February-1989.
21450 * Jack Dongarra, Argonne National Laboratory.
21451 * Iain Duff, AERE Harwell.
21452 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
21453 * Sven Hammarling, Numerical Algorithms Group Ltd.
21454 *
21455 *
21456 * .. External Functions ..
21457  LOGICAL LSAME
21458  EXTERNAL lsame
21459 * .. External Subroutines ..
21460  EXTERNAL xerbla
21461 * .. Intrinsic Functions ..
21462  INTRINSIC max
21463 * .. Local Scalars ..
21464  LOGICAL LSIDE, NOUNIT, UPPER
21465  INTEGER I, INFO, J, K, NROWA
21466  REAL TEMP
21467 * .. Parameters ..
21468  REAL ONE , ZERO
21469  parameter( one = 1.0e+0, zero = 0.0e+0 )
21470 * ..
21471 * .. Executable Statements ..
21472 *
21473 * Test the input parameters.
21474 *
21475  lside = lsame( side , 'L' )
21476  IF( lside )THEN
21477  nrowa = m
21478  ELSE
21479  nrowa = n
21480  END IF
21481  nounit = lsame( diag , 'N' )
21482  upper = lsame( uplo , 'U' )
21483 *
21484  info = 0
21485  IF( ( .NOT.lside ).AND.
21486  $ ( .NOT.lsame( side , 'R' ) ) )THEN
21487  info = 1
21488  ELSE IF( ( .NOT.upper ).AND.
21489  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
21490  info = 2
21491  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
21492  $ ( .NOT.lsame( transa, 'T' ) ).AND.
21493  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
21494  info = 3
21495  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
21496  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
21497  info = 4
21498  ELSE IF( m .LT.0 )THEN
21499  info = 5
21500  ELSE IF( n .LT.0 )THEN
21501  info = 6
21502  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
21503  info = 9
21504  ELSE IF( ldb.LT.max( 1, m ) )THEN
21505  info = 11
21506  END IF
21507  IF( info.NE.0 )THEN
21508  CALL xerbla( 'STRMM ', info )
21509  RETURN
21510  END IF
21511 *
21512 * Quick return if possible.
21513 *
21514  IF( n.EQ.0 )
21515  $ RETURN
21516 *
21517 * And when alpha.eq.zero.
21518 *
21519  IF( alpha.EQ.zero )THEN
21520  DO 20, j = 1, n
21521  DO 10, i = 1, m
21522  b( i, j ) = zero
21523  10 CONTINUE
21524  20 CONTINUE
21525  RETURN
21526  END IF
21527 *
21528 * Start the operations.
21529 *
21530  IF( lside )THEN
21531  IF( lsame( transa, 'N' ) )THEN
21532 *
21533 * Form B := alpha*A*B.
21534 *
21535  IF( upper )THEN
21536  DO 50, j = 1, n
21537  DO 40, k = 1, m
21538  IF( b( k, j ).NE.zero )THEN
21539  temp = alpha*b( k, j )
21540  DO 30, i = 1, k - 1
21541  b( i, j ) = b( i, j ) + temp*a( i, k )
21542  30 CONTINUE
21543  IF( nounit )
21544  $ temp = temp*a( k, k )
21545  b( k, j ) = temp
21546  END IF
21547  40 CONTINUE
21548  50 CONTINUE
21549  ELSE
21550  DO 80, j = 1, n
21551  DO 70 k = m, 1, -1
21552  IF( b( k, j ).NE.zero )THEN
21553  temp = alpha*b( k, j )
21554  b( k, j ) = temp
21555  IF( nounit )
21556  $ b( k, j ) = b( k, j )*a( k, k )
21557  DO 60, i = k + 1, m
21558  b( i, j ) = b( i, j ) + temp*a( i, k )
21559  60 CONTINUE
21560  END IF
21561  70 CONTINUE
21562  80 CONTINUE
21563  END IF
21564  ELSE
21565 *
21566 * Form B := alpha*A'*B.
21567 *
21568  IF( upper )THEN
21569  DO 110, j = 1, n
21570  DO 100, i = m, 1, -1
21571  temp = b( i, j )
21572  IF( nounit )
21573  $ temp = temp*a( i, i )
21574  DO 90, k = 1, i - 1
21575  temp = temp + a( k, i )*b( k, j )
21576  90 CONTINUE
21577  b( i, j ) = alpha*temp
21578  100 CONTINUE
21579  110 CONTINUE
21580  ELSE
21581  DO 140, j = 1, n
21582  DO 130, i = 1, m
21583  temp = b( i, j )
21584  IF( nounit )
21585  $ temp = temp*a( i, i )
21586  DO 120, k = i + 1, m
21587  temp = temp + a( k, i )*b( k, j )
21588  120 CONTINUE
21589  b( i, j ) = alpha*temp
21590  130 CONTINUE
21591  140 CONTINUE
21592  END IF
21593  END IF
21594  ELSE
21595  IF( lsame( transa, 'N' ) )THEN
21596 *
21597 * Form B := alpha*B*A.
21598 *
21599  IF( upper )THEN
21600  DO 180, j = n, 1, -1
21601  temp = alpha
21602  IF( nounit )
21603  $ temp = temp*a( j, j )
21604  DO 150, i = 1, m
21605  b( i, j ) = temp*b( i, j )
21606  150 CONTINUE
21607  DO 170, k = 1, j - 1
21608  IF( a( k, j ).NE.zero )THEN
21609  temp = alpha*a( k, j )
21610  DO 160, i = 1, m
21611  b( i, j ) = b( i, j ) + temp*b( i, k )
21612  160 CONTINUE
21613  END IF
21614  170 CONTINUE
21615  180 CONTINUE
21616  ELSE
21617  DO 220, j = 1, n
21618  temp = alpha
21619  IF( nounit )
21620  $ temp = temp*a( j, j )
21621  DO 190, i = 1, m
21622  b( i, j ) = temp*b( i, j )
21623  190 CONTINUE
21624  DO 210, k = j + 1, n
21625  IF( a( k, j ).NE.zero )THEN
21626  temp = alpha*a( k, j )
21627  DO 200, i = 1, m
21628  b( i, j ) = b( i, j ) + temp*b( i, k )
21629  200 CONTINUE
21630  END IF
21631  210 CONTINUE
21632  220 CONTINUE
21633  END IF
21634  ELSE
21635 *
21636 * Form B := alpha*B*A'.
21637 *
21638  IF( upper )THEN
21639  DO 260, k = 1, n
21640  DO 240, j = 1, k - 1
21641  IF( a( j, k ).NE.zero )THEN
21642  temp = alpha*a( j, k )
21643  DO 230, i = 1, m
21644  b( i, j ) = b( i, j ) + temp*b( i, k )
21645  230 CONTINUE
21646  END IF
21647  240 CONTINUE
21648  temp = alpha
21649  IF( nounit )
21650  $ temp = temp*a( k, k )
21651  IF( temp.NE.one )THEN
21652  DO 250, i = 1, m
21653  b( i, k ) = temp*b( i, k )
21654  250 CONTINUE
21655  END IF
21656  260 CONTINUE
21657  ELSE
21658  DO 300, k = n, 1, -1
21659  DO 280, j = k + 1, n
21660  IF( a( j, k ).NE.zero )THEN
21661  temp = alpha*a( j, k )
21662  DO 270, i = 1, m
21663  b( i, j ) = b( i, j ) + temp*b( i, k )
21664  270 CONTINUE
21665  END IF
21666  280 CONTINUE
21667  temp = alpha
21668  IF( nounit )
21669  $ temp = temp*a( k, k )
21670  IF( temp.NE.one )THEN
21671  DO 290, i = 1, m
21672  b( i, k ) = temp*b( i, k )
21673  290 CONTINUE
21674  END IF
21675  300 CONTINUE
21676  END IF
21677  END IF
21678  END IF
21679 *
21680  RETURN
21681 *
21682 * End of STRMM .
21683 *
21684  END
21685  SUBROUTINE strmv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
21686 * .. Scalar Arguments ..
21687  INTEGER INCX, LDA, N
21688  CHARACTER*1 DIAG, TRANS, UPLO
21689 * .. Array Arguments ..
21690  REAL A( lda, * ), X( * )
21691 * ..
21692 *
21693 * Purpose
21694 * =======
21695 *
21696 * STRMV performs one of the matrix-vector operations
21697 *
21698 * x := A*x, or x := A'*x,
21699 *
21700 * where x is an n element vector and A is an n by n unit, or non-unit,
21701 * upper or lower triangular matrix.
21702 *
21703 * Parameters
21704 * ==========
21705 *
21706 * UPLO - CHARACTER*1.
21707 * On entry, UPLO specifies whether the matrix is an upper or
21708 * lower triangular matrix as follows:
21709 *
21710 * UPLO = 'U' or 'u' A is an upper triangular matrix.
21711 *
21712 * UPLO = 'L' or 'l' A is a lower triangular matrix.
21713 *
21714 * Unchanged on exit.
21715 *
21716 * TRANS - CHARACTER*1.
21717 * On entry, TRANS specifies the operation to be performed as
21718 * follows:
21719 *
21720 * TRANS = 'N' or 'n' x := A*x.
21721 *
21722 * TRANS = 'T' or 't' x := A'*x.
21723 *
21724 * TRANS = 'C' or 'c' x := A'*x.
21725 *
21726 * Unchanged on exit.
21727 *
21728 * DIAG - CHARACTER*1.
21729 * On entry, DIAG specifies whether or not A is unit
21730 * triangular as follows:
21731 *
21732 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
21733 *
21734 * DIAG = 'N' or 'n' A is not assumed to be unit
21735 * triangular.
21736 *
21737 * Unchanged on exit.
21738 *
21739 * N - INTEGER.
21740 * On entry, N specifies the order of the matrix A.
21741 * N must be at least zero.
21742 * Unchanged on exit.
21743 *
21744 * A - REAL array of DIMENSION ( LDA, n ).
21745 * Before entry with UPLO = 'U' or 'u', the leading n by n
21746 * upper triangular part of the array A must contain the upper
21747 * triangular matrix and the strictly lower triangular part of
21748 * A is not referenced.
21749 * Before entry with UPLO = 'L' or 'l', the leading n by n
21750 * lower triangular part of the array A must contain the lower
21751 * triangular matrix and the strictly upper triangular part of
21752 * A is not referenced.
21753 * Note that when DIAG = 'U' or 'u', the diagonal elements of
21754 * A are not referenced either, but are assumed to be unity.
21755 * Unchanged on exit.
21756 *
21757 * LDA - INTEGER.
21758 * On entry, LDA specifies the first dimension of A as declared
21759 * in the calling (sub) program. LDA must be at least
21760 * max( 1, n ).
21761 * Unchanged on exit.
21762 *
21763 * X - REAL array of dimension at least
21764 * ( 1 + ( n - 1 )*abs( INCX ) ).
21765 * Before entry, the incremented array X must contain the n
21766 * element vector x. On exit, X is overwritten with the
21767 * tranformed vector x.
21768 *
21769 * INCX - INTEGER.
21770 * On entry, INCX specifies the increment for the elements of
21771 * X. INCX must not be zero.
21772 * Unchanged on exit.
21773 *
21774 *
21775 * Level 2 Blas routine.
21776 *
21777 * -- Written on 22-October-1986.
21778 * Jack Dongarra, Argonne National Lab.
21779 * Jeremy Du Croz, Nag Central Office.
21780 * Sven Hammarling, Nag Central Office.
21781 * Richard Hanson, Sandia National Labs.
21782 *
21783 *
21784 * .. Parameters ..
21785  REAL ZERO
21786  parameter( zero = 0.0e+0 )
21787 * .. Local Scalars ..
21788  REAL TEMP
21789  INTEGER I, INFO, IX, J, JX, KX
21790  LOGICAL NOUNIT
21791 * .. External Functions ..
21792  LOGICAL LSAME
21793  EXTERNAL lsame
21794 * .. External Subroutines ..
21795  EXTERNAL xerbla
21796 * .. Intrinsic Functions ..
21797  INTRINSIC max
21798 * ..
21799 * .. Executable Statements ..
21800 *
21801 * Test the input parameters.
21802 *
21803  info = 0
21804  IF ( .NOT.lsame( uplo , 'U' ).AND.
21805  $ .NOT.lsame( uplo , 'L' ) )THEN
21806  info = 1
21807  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
21808  $ .NOT.lsame( trans, 'T' ).AND.
21809  $ .NOT.lsame( trans, 'C' ) )THEN
21810  info = 2
21811  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
21812  $ .NOT.lsame( diag , 'N' ) )THEN
21813  info = 3
21814  ELSE IF( n.LT.0 )THEN
21815  info = 4
21816  ELSE IF( lda.LT.max( 1, n ) )THEN
21817  info = 6
21818  ELSE IF( incx.EQ.0 )THEN
21819  info = 8
21820  END IF
21821  IF( info.NE.0 )THEN
21822  CALL xerbla( 'STRMV ', info )
21823  RETURN
21824  END IF
21825 *
21826 * Quick return if possible.
21827 *
21828  IF( n.EQ.0 )
21829  $ RETURN
21830 *
21831  nounit = lsame( diag, 'N' )
21832 *
21833 * Set up the start point in X if the increment is not unity. This
21834 * will be ( N - 1 )*INCX too small for descending loops.
21835 *
21836  IF( incx.LE.0 )THEN
21837  kx = 1 - ( n - 1 )*incx
21838  ELSE IF( incx.NE.1 )THEN
21839  kx = 1
21840  END IF
21841 *
21842 * Start the operations. In this version the elements of A are
21843 * accessed sequentially with one pass through A.
21844 *
21845  IF( lsame( trans, 'N' ) )THEN
21846 *
21847 * Form x := A*x.
21848 *
21849  IF( lsame( uplo, 'U' ) )THEN
21850  IF( incx.EQ.1 )THEN
21851  DO 20, j = 1, n
21852  IF( x( j ).NE.zero )THEN
21853  temp = x( j )
21854  DO 10, i = 1, j - 1
21855  x( i ) = x( i ) + temp*a( i, j )
21856  10 CONTINUE
21857  IF( nounit )
21858  $ x( j ) = x( j )*a( j, j )
21859  END IF
21860  20 CONTINUE
21861  ELSE
21862  jx = kx
21863  DO 40, j = 1, n
21864  IF( x( jx ).NE.zero )THEN
21865  temp = x( jx )
21866  ix = kx
21867  DO 30, i = 1, j - 1
21868  x( ix ) = x( ix ) + temp*a( i, j )
21869  ix = ix + incx
21870  30 CONTINUE
21871  IF( nounit )
21872  $ x( jx ) = x( jx )*a( j, j )
21873  END IF
21874  jx = jx + incx
21875  40 CONTINUE
21876  END IF
21877  ELSE
21878  IF( incx.EQ.1 )THEN
21879  DO 60, j = n, 1, -1
21880  IF( x( j ).NE.zero )THEN
21881  temp = x( j )
21882  DO 50, i = n, j + 1, -1
21883  x( i ) = x( i ) + temp*a( i, j )
21884  50 CONTINUE
21885  IF( nounit )
21886  $ x( j ) = x( j )*a( j, j )
21887  END IF
21888  60 CONTINUE
21889  ELSE
21890  kx = kx + ( n - 1 )*incx
21891  jx = kx
21892  DO 80, j = n, 1, -1
21893  IF( x( jx ).NE.zero )THEN
21894  temp = x( jx )
21895  ix = kx
21896  DO 70, i = n, j + 1, -1
21897  x( ix ) = x( ix ) + temp*a( i, j )
21898  ix = ix - incx
21899  70 CONTINUE
21900  IF( nounit )
21901  $ x( jx ) = x( jx )*a( j, j )
21902  END IF
21903  jx = jx - incx
21904  80 CONTINUE
21905  END IF
21906  END IF
21907  ELSE
21908 *
21909 * Form x := A'*x.
21910 *
21911  IF( lsame( uplo, 'U' ) )THEN
21912  IF( incx.EQ.1 )THEN
21913  DO 100, j = n, 1, -1
21914  temp = x( j )
21915  IF( nounit )
21916  $ temp = temp*a( j, j )
21917  DO 90, i = j - 1, 1, -1
21918  temp = temp + a( i, j )*x( i )
21919  90 CONTINUE
21920  x( j ) = temp
21921  100 CONTINUE
21922  ELSE
21923  jx = kx + ( n - 1 )*incx
21924  DO 120, j = n, 1, -1
21925  temp = x( jx )
21926  ix = jx
21927  IF( nounit )
21928  $ temp = temp*a( j, j )
21929  DO 110, i = j - 1, 1, -1
21930  ix = ix - incx
21931  temp = temp + a( i, j )*x( ix )
21932  110 CONTINUE
21933  x( jx ) = temp
21934  jx = jx - incx
21935  120 CONTINUE
21936  END IF
21937  ELSE
21938  IF( incx.EQ.1 )THEN
21939  DO 140, j = 1, n
21940  temp = x( j )
21941  IF( nounit )
21942  $ temp = temp*a( j, j )
21943  DO 130, i = j + 1, n
21944  temp = temp + a( i, j )*x( i )
21945  130 CONTINUE
21946  x( j ) = temp
21947  140 CONTINUE
21948  ELSE
21949  jx = kx
21950  DO 160, j = 1, n
21951  temp = x( jx )
21952  ix = jx
21953  IF( nounit )
21954  $ temp = temp*a( j, j )
21955  DO 150, i = j + 1, n
21956  ix = ix + incx
21957  temp = temp + a( i, j )*x( ix )
21958  150 CONTINUE
21959  x( jx ) = temp
21960  jx = jx + incx
21961  160 CONTINUE
21962  END IF
21963  END IF
21964  END IF
21965 *
21966  RETURN
21967 *
21968 * End of STRMV .
21969 *
21970  END
21971  SUBROUTINE strsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
21972  $ b, ldb )
21973 * .. Scalar Arguments ..
21974  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
21975  INTEGER M, N, LDA, LDB
21976  REAL ALPHA
21977 * .. Array Arguments ..
21978  REAL A( lda, * ), B( ldb, * )
21979 * ..
21980 *
21981 * Purpose
21982 * =======
21983 *
21984 * STRSM solves one of the matrix equations
21985 *
21986 * op( A )*X = alpha*B, or X*op( A ) = alpha*B,
21987 *
21988 * where alpha is a scalar, X and B are m by n matrices, A is a unit, or
21989 * non-unit, upper or lower triangular matrix and op( A ) is one of
21990 *
21991 * op( A ) = A or op( A ) = A'.
21992 *
21993 * The matrix X is overwritten on B.
21994 *
21995 * Parameters
21996 * ==========
21997 *
21998 * SIDE - CHARACTER*1.
21999 * On entry, SIDE specifies whether op( A ) appears on the left
22000 * or right of X as follows:
22001 *
22002 * SIDE = 'L' or 'l' op( A )*X = alpha*B.
22003 *
22004 * SIDE = 'R' or 'r' X*op( A ) = alpha*B.
22005 *
22006 * Unchanged on exit.
22007 *
22008 * UPLO - CHARACTER*1.
22009 * On entry, UPLO specifies whether the matrix A is an upper or
22010 * lower triangular matrix as follows:
22011 *
22012 * UPLO = 'U' or 'u' A is an upper triangular matrix.
22013 *
22014 * UPLO = 'L' or 'l' A is a lower triangular matrix.
22015 *
22016 * Unchanged on exit.
22017 *
22018 * TRANSA - CHARACTER*1.
22019 * On entry, TRANSA specifies the form of op( A ) to be used in
22020 * the matrix multiplication as follows:
22021 *
22022 * TRANSA = 'N' or 'n' op( A ) = A.
22023 *
22024 * TRANSA = 'T' or 't' op( A ) = A'.
22025 *
22026 * TRANSA = 'C' or 'c' op( A ) = A'.
22027 *
22028 * Unchanged on exit.
22029 *
22030 * DIAG - CHARACTER*1.
22031 * On entry, DIAG specifies whether or not A is unit triangular
22032 * as follows:
22033 *
22034 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
22035 *
22036 * DIAG = 'N' or 'n' A is not assumed to be unit
22037 * triangular.
22038 *
22039 * Unchanged on exit.
22040 *
22041 * M - INTEGER.
22042 * On entry, M specifies the number of rows of B. M must be at
22043 * least zero.
22044 * Unchanged on exit.
22045 *
22046 * N - INTEGER.
22047 * On entry, N specifies the number of columns of B. N must be
22048 * at least zero.
22049 * Unchanged on exit.
22050 *
22051 * ALPHA - REAL .
22052 * On entry, ALPHA specifies the scalar alpha. When alpha is
22053 * zero then A is not referenced and B need not be set before
22054 * entry.
22055 * Unchanged on exit.
22056 *
22057 * A - REAL array of DIMENSION ( LDA, k ), where k is m
22058 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
22059 * Before entry with UPLO = 'U' or 'u', the leading k by k
22060 * upper triangular part of the array A must contain the upper
22061 * triangular matrix and the strictly lower triangular part of
22062 * A is not referenced.
22063 * Before entry with UPLO = 'L' or 'l', the leading k by k
22064 * lower triangular part of the array A must contain the lower
22065 * triangular matrix and the strictly upper triangular part of
22066 * A is not referenced.
22067 * Note that when DIAG = 'U' or 'u', the diagonal elements of
22068 * A are not referenced either, but are assumed to be unity.
22069 * Unchanged on exit.
22070 *
22071 * LDA - INTEGER.
22072 * On entry, LDA specifies the first dimension of A as declared
22073 * in the calling (sub) program. When SIDE = 'L' or 'l' then
22074 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
22075 * then LDA must be at least max( 1, n ).
22076 * Unchanged on exit.
22077 *
22078 * B - REAL array of DIMENSION ( LDB, n ).
22079 * Before entry, the leading m by n part of the array B must
22080 * contain the right-hand side matrix B, and on exit is
22081 * overwritten by the solution matrix X.
22082 *
22083 * LDB - INTEGER.
22084 * On entry, LDB specifies the first dimension of B as declared
22085 * in the calling (sub) program. LDB must be at least
22086 * max( 1, m ).
22087 * Unchanged on exit.
22088 *
22089 *
22090 * Level 3 Blas routine.
22091 *
22092 *
22093 * -- Written on 8-February-1989.
22094 * Jack Dongarra, Argonne National Laboratory.
22095 * Iain Duff, AERE Harwell.
22096 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
22097 * Sven Hammarling, Numerical Algorithms Group Ltd.
22098 *
22099 *
22100 * .. External Functions ..
22101  LOGICAL LSAME
22102  EXTERNAL lsame
22103 * .. External Subroutines ..
22104  EXTERNAL xerbla
22105 * .. Intrinsic Functions ..
22106  INTRINSIC max
22107 * .. Local Scalars ..
22108  LOGICAL LSIDE, NOUNIT, UPPER
22109  INTEGER I, INFO, J, K, NROWA
22110  REAL TEMP
22111 * .. Parameters ..
22112  REAL ONE , ZERO
22113  parameter( one = 1.0e+0, zero = 0.0e+0 )
22114 * ..
22115 * .. Executable Statements ..
22116 *
22117 * Test the input parameters.
22118 *
22119  lside = lsame( side , 'L' )
22120  IF( lside )THEN
22121  nrowa = m
22122  ELSE
22123  nrowa = n
22124  END IF
22125  nounit = lsame( diag , 'N' )
22126  upper = lsame( uplo , 'U' )
22127 *
22128  info = 0
22129  IF( ( .NOT.lside ).AND.
22130  $ ( .NOT.lsame( side , 'R' ) ) )THEN
22131  info = 1
22132  ELSE IF( ( .NOT.upper ).AND.
22133  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
22134  info = 2
22135  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
22136  $ ( .NOT.lsame( transa, 'T' ) ).AND.
22137  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
22138  info = 3
22139  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
22140  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
22141  info = 4
22142  ELSE IF( m .LT.0 )THEN
22143  info = 5
22144  ELSE IF( n .LT.0 )THEN
22145  info = 6
22146  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
22147  info = 9
22148  ELSE IF( ldb.LT.max( 1, m ) )THEN
22149  info = 11
22150  END IF
22151  IF( info.NE.0 )THEN
22152  CALL xerbla( 'STRSM ', info )
22153  RETURN
22154  END IF
22155 *
22156 * Quick return if possible.
22157 *
22158  IF( n.EQ.0 )
22159  $ RETURN
22160 *
22161 * And when alpha.eq.zero.
22162 *
22163  IF( alpha.EQ.zero )THEN
22164  DO 20, j = 1, n
22165  DO 10, i = 1, m
22166  b( i, j ) = zero
22167  10 CONTINUE
22168  20 CONTINUE
22169  RETURN
22170  END IF
22171 *
22172 * Start the operations.
22173 *
22174  IF( lside )THEN
22175  IF( lsame( transa, 'N' ) )THEN
22176 *
22177 * Form B := alpha*inv( A )*B.
22178 *
22179  IF( upper )THEN
22180  DO 60, j = 1, n
22181  IF( alpha.NE.one )THEN
22182  DO 30, i = 1, m
22183  b( i, j ) = alpha*b( i, j )
22184  30 CONTINUE
22185  END IF
22186  DO 50, k = m, 1, -1
22187  IF( b( k, j ).NE.zero )THEN
22188  IF( nounit )
22189  $ b( k, j ) = b( k, j )/a( k, k )
22190  DO 40, i = 1, k - 1
22191  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
22192  40 CONTINUE
22193  END IF
22194  50 CONTINUE
22195  60 CONTINUE
22196  ELSE
22197  DO 100, j = 1, n
22198  IF( alpha.NE.one )THEN
22199  DO 70, i = 1, m
22200  b( i, j ) = alpha*b( i, j )
22201  70 CONTINUE
22202  END IF
22203  DO 90 k = 1, m
22204  IF( b( k, j ).NE.zero )THEN
22205  IF( nounit )
22206  $ b( k, j ) = b( k, j )/a( k, k )
22207  DO 80, i = k + 1, m
22208  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
22209  80 CONTINUE
22210  END IF
22211  90 CONTINUE
22212  100 CONTINUE
22213  END IF
22214  ELSE
22215 *
22216 * Form B := alpha*inv( A' )*B.
22217 *
22218  IF( upper )THEN
22219  DO 130, j = 1, n
22220  DO 120, i = 1, m
22221  temp = alpha*b( i, j )
22222  DO 110, k = 1, i - 1
22223  temp = temp - a( k, i )*b( k, j )
22224  110 CONTINUE
22225  IF( nounit )
22226  $ temp = temp/a( i, i )
22227  b( i, j ) = temp
22228  120 CONTINUE
22229  130 CONTINUE
22230  ELSE
22231  DO 160, j = 1, n
22232  DO 150, i = m, 1, -1
22233  temp = alpha*b( i, j )
22234  DO 140, k = i + 1, m
22235  temp = temp - a( k, i )*b( k, j )
22236  140 CONTINUE
22237  IF( nounit )
22238  $ temp = temp/a( i, i )
22239  b( i, j ) = temp
22240  150 CONTINUE
22241  160 CONTINUE
22242  END IF
22243  END IF
22244  ELSE
22245  IF( lsame( transa, 'N' ) )THEN
22246 *
22247 * Form B := alpha*B*inv( A ).
22248 *
22249  IF( upper )THEN
22250  DO 210, j = 1, n
22251  IF( alpha.NE.one )THEN
22252  DO 170, i = 1, m
22253  b( i, j ) = alpha*b( i, j )
22254  170 CONTINUE
22255  END IF
22256  DO 190, k = 1, j - 1
22257  IF( a( k, j ).NE.zero )THEN
22258  DO 180, i = 1, m
22259  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
22260  180 CONTINUE
22261  END IF
22262  190 CONTINUE
22263  IF( nounit )THEN
22264  temp = one/a( j, j )
22265  DO 200, i = 1, m
22266  b( i, j ) = temp*b( i, j )
22267  200 CONTINUE
22268  END IF
22269  210 CONTINUE
22270  ELSE
22271  DO 260, j = n, 1, -1
22272  IF( alpha.NE.one )THEN
22273  DO 220, i = 1, m
22274  b( i, j ) = alpha*b( i, j )
22275  220 CONTINUE
22276  END IF
22277  DO 240, k = j + 1, n
22278  IF( a( k, j ).NE.zero )THEN
22279  DO 230, i = 1, m
22280  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
22281  230 CONTINUE
22282  END IF
22283  240 CONTINUE
22284  IF( nounit )THEN
22285  temp = one/a( j, j )
22286  DO 250, i = 1, m
22287  b( i, j ) = temp*b( i, j )
22288  250 CONTINUE
22289  END IF
22290  260 CONTINUE
22291  END IF
22292  ELSE
22293 *
22294 * Form B := alpha*B*inv( A' ).
22295 *
22296  IF( upper )THEN
22297  DO 310, k = n, 1, -1
22298  IF( nounit )THEN
22299  temp = one/a( k, k )
22300  DO 270, i = 1, m
22301  b( i, k ) = temp*b( i, k )
22302  270 CONTINUE
22303  END IF
22304  DO 290, j = 1, k - 1
22305  IF( a( j, k ).NE.zero )THEN
22306  temp = a( j, k )
22307  DO 280, i = 1, m
22308  b( i, j ) = b( i, j ) - temp*b( i, k )
22309  280 CONTINUE
22310  END IF
22311  290 CONTINUE
22312  IF( alpha.NE.one )THEN
22313  DO 300, i = 1, m
22314  b( i, k ) = alpha*b( i, k )
22315  300 CONTINUE
22316  END IF
22317  310 CONTINUE
22318  ELSE
22319  DO 360, k = 1, n
22320  IF( nounit )THEN
22321  temp = one/a( k, k )
22322  DO 320, i = 1, m
22323  b( i, k ) = temp*b( i, k )
22324  320 CONTINUE
22325  END IF
22326  DO 340, j = k + 1, n
22327  IF( a( j, k ).NE.zero )THEN
22328  temp = a( j, k )
22329  DO 330, i = 1, m
22330  b( i, j ) = b( i, j ) - temp*b( i, k )
22331  330 CONTINUE
22332  END IF
22333  340 CONTINUE
22334  IF( alpha.NE.one )THEN
22335  DO 350, i = 1, m
22336  b( i, k ) = alpha*b( i, k )
22337  350 CONTINUE
22338  END IF
22339  360 CONTINUE
22340  END IF
22341  END IF
22342  END IF
22343 *
22344  RETURN
22345 *
22346 * End of STRSM .
22347 *
22348  END
22349  SUBROUTINE strsv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
22350 * .. Scalar Arguments ..
22351  INTEGER INCX, LDA, N
22352  CHARACTER*1 DIAG, TRANS, UPLO
22353 * .. Array Arguments ..
22354  REAL A( lda, * ), X( * )
22355 * ..
22356 *
22357 * Purpose
22358 * =======
22359 *
22360 * STRSV solves one of the systems of equations
22361 *
22362 * A*x = b, or A'*x = b,
22363 *
22364 * where b and x are n element vectors and A is an n by n unit, or
22365 * non-unit, upper or lower triangular matrix.
22366 *
22367 * No test for singularity or near-singularity is included in this
22368 * routine. Such tests must be performed before calling this routine.
22369 *
22370 * Parameters
22371 * ==========
22372 *
22373 * UPLO - CHARACTER*1.
22374 * On entry, UPLO specifies whether the matrix is an upper or
22375 * lower triangular matrix as follows:
22376 *
22377 * UPLO = 'U' or 'u' A is an upper triangular matrix.
22378 *
22379 * UPLO = 'L' or 'l' A is a lower triangular matrix.
22380 *
22381 * Unchanged on exit.
22382 *
22383 * TRANS - CHARACTER*1.
22384 * On entry, TRANS specifies the equations to be solved as
22385 * follows:
22386 *
22387 * TRANS = 'N' or 'n' A*x = b.
22388 *
22389 * TRANS = 'T' or 't' A'*x = b.
22390 *
22391 * TRANS = 'C' or 'c' A'*x = b.
22392 *
22393 * Unchanged on exit.
22394 *
22395 * DIAG - CHARACTER*1.
22396 * On entry, DIAG specifies whether or not A is unit
22397 * triangular as follows:
22398 *
22399 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
22400 *
22401 * DIAG = 'N' or 'n' A is not assumed to be unit
22402 * triangular.
22403 *
22404 * Unchanged on exit.
22405 *
22406 * N - INTEGER.
22407 * On entry, N specifies the order of the matrix A.
22408 * N must be at least zero.
22409 * Unchanged on exit.
22410 *
22411 * A - REAL array of DIMENSION ( LDA, n ).
22412 * Before entry with UPLO = 'U' or 'u', the leading n by n
22413 * upper triangular part of the array A must contain the upper
22414 * triangular matrix and the strictly lower triangular part of
22415 * A is not referenced.
22416 * Before entry with UPLO = 'L' or 'l', the leading n by n
22417 * lower triangular part of the array A must contain the lower
22418 * triangular matrix and the strictly upper triangular part of
22419 * A is not referenced.
22420 * Note that when DIAG = 'U' or 'u', the diagonal elements of
22421 * A are not referenced either, but are assumed to be unity.
22422 * Unchanged on exit.
22423 *
22424 * LDA - INTEGER.
22425 * On entry, LDA specifies the first dimension of A as declared
22426 * in the calling (sub) program. LDA must be at least
22427 * max( 1, n ).
22428 * Unchanged on exit.
22429 *
22430 * X - REAL array of dimension at least
22431 * ( 1 + ( n - 1 )*abs( INCX ) ).
22432 * Before entry, the incremented array X must contain the n
22433 * element right-hand side vector b. On exit, X is overwritten
22434 * with the solution vector x.
22435 *
22436 * INCX - INTEGER.
22437 * On entry, INCX specifies the increment for the elements of
22438 * X. INCX must not be zero.
22439 * Unchanged on exit.
22440 *
22441 *
22442 * Level 2 Blas routine.
22443 *
22444 * -- Written on 22-October-1986.
22445 * Jack Dongarra, Argonne National Lab.
22446 * Jeremy Du Croz, Nag Central Office.
22447 * Sven Hammarling, Nag Central Office.
22448 * Richard Hanson, Sandia National Labs.
22449 *
22450 *
22451 * .. Parameters ..
22452  REAL ZERO
22453  parameter( zero = 0.0e+0 )
22454 * .. Local Scalars ..
22455  REAL TEMP
22456  INTEGER I, INFO, IX, J, JX, KX
22457  LOGICAL NOUNIT
22458 * .. External Functions ..
22459  LOGICAL LSAME
22460  EXTERNAL lsame
22461 * .. External Subroutines ..
22462  EXTERNAL xerbla
22463 * .. Intrinsic Functions ..
22464  INTRINSIC max
22465 * ..
22466 * .. Executable Statements ..
22467 *
22468 * Test the input parameters.
22469 *
22470  info = 0
22471  IF ( .NOT.lsame( uplo , 'U' ).AND.
22472  $ .NOT.lsame( uplo , 'L' ) )THEN
22473  info = 1
22474  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
22475  $ .NOT.lsame( trans, 'T' ).AND.
22476  $ .NOT.lsame( trans, 'C' ) )THEN
22477  info = 2
22478  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
22479  $ .NOT.lsame( diag , 'N' ) )THEN
22480  info = 3
22481  ELSE IF( n.LT.0 )THEN
22482  info = 4
22483  ELSE IF( lda.LT.max( 1, n ) )THEN
22484  info = 6
22485  ELSE IF( incx.EQ.0 )THEN
22486  info = 8
22487  END IF
22488  IF( info.NE.0 )THEN
22489  CALL xerbla( 'STRSV ', info )
22490  RETURN
22491  END IF
22492 *
22493 * Quick return if possible.
22494 *
22495  IF( n.EQ.0 )
22496  $ RETURN
22497 *
22498  nounit = lsame( diag, 'N' )
22499 *
22500 * Set up the start point in X if the increment is not unity. This
22501 * will be ( N - 1 )*INCX too small for descending loops.
22502 *
22503  IF( incx.LE.0 )THEN
22504  kx = 1 - ( n - 1 )*incx
22505  ELSE IF( incx.NE.1 )THEN
22506  kx = 1
22507  END IF
22508 *
22509 * Start the operations. In this version the elements of A are
22510 * accessed sequentially with one pass through A.
22511 *
22512  IF( lsame( trans, 'N' ) )THEN
22513 *
22514 * Form x := inv( A )*x.
22515 *
22516  IF( lsame( uplo, 'U' ) )THEN
22517  IF( incx.EQ.1 )THEN
22518  DO 20, j = n, 1, -1
22519  IF( x( j ).NE.zero )THEN
22520  IF( nounit )
22521  $ x( j ) = x( j )/a( j, j )
22522  temp = x( j )
22523  DO 10, i = j - 1, 1, -1
22524  x( i ) = x( i ) - temp*a( i, j )
22525  10 CONTINUE
22526  END IF
22527  20 CONTINUE
22528  ELSE
22529  jx = kx + ( n - 1 )*incx
22530  DO 40, j = n, 1, -1
22531  IF( x( jx ).NE.zero )THEN
22532  IF( nounit )
22533  $ x( jx ) = x( jx )/a( j, j )
22534  temp = x( jx )
22535  ix = jx
22536  DO 30, i = j - 1, 1, -1
22537  ix = ix - incx
22538  x( ix ) = x( ix ) - temp*a( i, j )
22539  30 CONTINUE
22540  END IF
22541  jx = jx - incx
22542  40 CONTINUE
22543  END IF
22544  ELSE
22545  IF( incx.EQ.1 )THEN
22546  DO 60, j = 1, n
22547  IF( x( j ).NE.zero )THEN
22548  IF( nounit )
22549  $ x( j ) = x( j )/a( j, j )
22550  temp = x( j )
22551  DO 50, i = j + 1, n
22552  x( i ) = x( i ) - temp*a( i, j )
22553  50 CONTINUE
22554  END IF
22555  60 CONTINUE
22556  ELSE
22557  jx = kx
22558  DO 80, j = 1, n
22559  IF( x( jx ).NE.zero )THEN
22560  IF( nounit )
22561  $ x( jx ) = x( jx )/a( j, j )
22562  temp = x( jx )
22563  ix = jx
22564  DO 70, i = j + 1, n
22565  ix = ix + incx
22566  x( ix ) = x( ix ) - temp*a( i, j )
22567  70 CONTINUE
22568  END IF
22569  jx = jx + incx
22570  80 CONTINUE
22571  END IF
22572  END IF
22573  ELSE
22574 *
22575 * Form x := inv( A' )*x.
22576 *
22577  IF( lsame( uplo, 'U' ) )THEN
22578  IF( incx.EQ.1 )THEN
22579  DO 100, j = 1, n
22580  temp = x( j )
22581  DO 90, i = 1, j - 1
22582  temp = temp - a( i, j )*x( i )
22583  90 CONTINUE
22584  IF( nounit )
22585  $ temp = temp/a( j, j )
22586  x( j ) = temp
22587  100 CONTINUE
22588  ELSE
22589  jx = kx
22590  DO 120, j = 1, n
22591  temp = x( jx )
22592  ix = kx
22593  DO 110, i = 1, j - 1
22594  temp = temp - a( i, j )*x( ix )
22595  ix = ix + incx
22596  110 CONTINUE
22597  IF( nounit )
22598  $ temp = temp/a( j, j )
22599  x( jx ) = temp
22600  jx = jx + incx
22601  120 CONTINUE
22602  END IF
22603  ELSE
22604  IF( incx.EQ.1 )THEN
22605  DO 140, j = n, 1, -1
22606  temp = x( j )
22607  DO 130, i = n, j + 1, -1
22608  temp = temp - a( i, j )*x( i )
22609  130 CONTINUE
22610  IF( nounit )
22611  $ temp = temp/a( j, j )
22612  x( j ) = temp
22613  140 CONTINUE
22614  ELSE
22615  kx = kx + ( n - 1 )*incx
22616  jx = kx
22617  DO 160, j = n, 1, -1
22618  temp = x( jx )
22619  ix = kx
22620  DO 150, i = n, j + 1, -1
22621  temp = temp - a( i, j )*x( ix )
22622  ix = ix - incx
22623  150 CONTINUE
22624  IF( nounit )
22625  $ temp = temp/a( j, j )
22626  x( jx ) = temp
22627  jx = jx - incx
22628  160 CONTINUE
22629  END IF
22630  END IF
22631  END IF
22632 *
22633  RETURN
22634 *
22635 * End of STRSV .
22636 *
22637  END
22638  SUBROUTINE xerbla( SRNAME, INFO )
22639 *
22640 * -- LAPACK auxiliary routine (preliminary version) --
22641 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
22642 * Courant Institute, Argonne National Lab, and Rice University
22643 * February 29, 1992
22644 *
22645 * .. Scalar Arguments ..
22646  CHARACTER*6 SRNAME
22647  INTEGER INFO
22648 * ..
22649 *
22650 * Purpose
22651 * =======
22652 *
22653 * XERBLA is an error handler for the LAPACK routines.
22654 * It is called by an LAPACK routine if an input parameter has an
22655 * invalid value. A message is printed and execution stops.
22656 *
22657 * Installers may consider modifying the STOP statement in order to
22658 * call system-specific exception-handling facilities.
22659 *
22660 * Arguments
22661 * =========
22662 *
22663 * SRNAME (input) CHARACTER*6
22664 * The name of the routine which called XERBLA.
22665 *
22666 * INFO (input) INTEGER
22667 * The position of the invalid parameter in the parameter list
22668 * of the calling routine.
22669 *
22670 *
22671  WRITE( *, fmt = 9999 )srname, info
22672 *
22673  stop
22674 *
22675  9999 FORMAT( ' ** On entry to ', a6, ' parameter number ', i2, ' had ',
22676  $ 'an illegal value' )
22677 *
22678 * End of XERBLA
22679 *
22680  END
22681  subroutine zaxpy(n,za,zx,incx,zy,incy)
22682 c
22683 c constant times a vector plus a vector.
22684 c jack dongarra, 3/11/78.
22685 c modified 12/3/93, array(1) declarations changed to array(*)
22686 c
22687  double complex zx(*),zy(*),za
22688  integer i,incx,incy,ix,iy,n
22689  double precision dcabs1
22690  if(n.le.0)return
22691  if (dcabs1(za) .eq. 0.0d0) return
22692  if (incx.eq.1.and.incy.eq.1)go to 20
22693 c
22694 c code for unequal increments or equal increments
22695 c not equal to 1
22696 c
22697  ix = 1
22698  iy = 1
22699  if(incx.lt.0)ix = (-n+1)*incx + 1
22700  if(incy.lt.0)iy = (-n+1)*incy + 1
22701  do 10 i = 1,n
22702  zy(iy) = zy(iy) + za*zx(ix)
22703  ix = ix + incx
22704  iy = iy + incy
22705  10 continue
22706  return
22707 c
22708 c code for both increments equal to 1
22709 c
22710  20 do 30 i = 1,n
22711  zy(i) = zy(i) + za*zx(i)
22712  30 continue
22713  return
22714  end
22715  subroutine zcopy(n,zx,incx,zy,incy)
22716 c
22717 c copies a vector, x, to a vector, y.
22718 c jack dongarra, linpack, 4/11/78.
22719 c modified 12/3/93, array(1) declarations changed to array(*)
22720 c
22721  double complex zx(*),zy(*)
22722  integer i,incx,incy,ix,iy,n
22723 c
22724  if(n.le.0)return
22725  if(incx.eq.1.and.incy.eq.1)go to 20
22726 c
22727 c code for unequal increments or equal increments
22728 c not equal to 1
22729 c
22730  ix = 1
22731  iy = 1
22732  if(incx.lt.0)ix = (-n+1)*incx + 1
22733  if(incy.lt.0)iy = (-n+1)*incy + 1
22734  do 10 i = 1,n
22735  zy(iy) = zx(ix)
22736  ix = ix + incx
22737  iy = iy + incy
22738  10 continue
22739  return
22740 c
22741 c code for both increments equal to 1
22742 c
22743  20 do 30 i = 1,n
22744  zy(i) = zx(i)
22745  30 continue
22746  return
22747  end
22748  double complex function zdotc(n,zx,incx,zy,incy)
22749 c
22750 c forms the dot product of a vector.
22751 c jack dongarra, 3/11/78.
22752 c modified 12/3/93, array(1) declarations changed to array(*)
22753 c
22754  double complex zx(*),zy(*),ztemp
22755  integer i,incx,incy,ix,iy,n
22756  ztemp = (0.0d0,0.0d0)
22757  zdotc = (0.0d0,0.0d0)
22758  if(n.le.0)return
22759  if(incx.eq.1.and.incy.eq.1)go to 20
22760 c
22761 c code for unequal increments or equal increments
22762 c not equal to 1
22763 c
22764  ix = 1
22765  iy = 1
22766  if(incx.lt.0)ix = (-n+1)*incx + 1
22767  if(incy.lt.0)iy = (-n+1)*incy + 1
22768  do 10 i = 1,n
22769  ztemp = ztemp + dconjg(zx(ix))*zy(iy)
22770  ix = ix + incx
22771  iy = iy + incy
22772  10 continue
22773  zdotc = ztemp
22774  return
22775 c
22776 c code for both increments equal to 1
22777 c
22778  20 do 30 i = 1,n
22779  ztemp = ztemp + dconjg(zx(i))*zy(i)
22780  30 continue
22781  zdotc = ztemp
22782  return
22783  end
22784  double complex function zdotu(n,zx,incx,zy,incy)
22785 c
22786 c forms the dot product of two vectors.
22787 c jack dongarra, 3/11/78.
22788 c modified 12/3/93, array(1) declarations changed to array(*)
22789 c
22790  double complex zx(*),zy(*),ztemp
22791  integer i,incx,incy,ix,iy,n
22792  ztemp = (0.0d0,0.0d0)
22793  zdotu = (0.0d0,0.0d0)
22794  if(n.le.0)return
22795  if(incx.eq.1.and.incy.eq.1)go to 20
22796 c
22797 c code for unequal increments or equal increments
22798 c not equal to 1
22799 c
22800  ix = 1
22801  iy = 1
22802  if(incx.lt.0)ix = (-n+1)*incx + 1
22803  if(incy.lt.0)iy = (-n+1)*incy + 1
22804  do 10 i = 1,n
22805  ztemp = ztemp + zx(ix)*zy(iy)
22806  ix = ix + incx
22807  iy = iy + incy
22808  10 continue
22809  zdotu = ztemp
22810  return
22811 c
22812 c code for both increments equal to 1
22813 c
22814  20 do 30 i = 1,n
22815  ztemp = ztemp + zx(i)*zy(i)
22816  30 continue
22817  zdotu = ztemp
22818  return
22819  end
22820  subroutine zdrot (n,zx,incx,zy,incy,c,s)
22821 c
22822 c applies a plane rotation, where the cos and sin (c and s) are
22823 c double precision and the vectors zx and zy are double complex.
22824 c jack dongarra, linpack, 3/11/78.
22825 c
22826  double complex zx(1),zy(1),ztemp
22827  double precision c,s
22828  integer i,incx,incy,ix,iy,n
22829 c
22830  if(n.le.0)return
22831  if(incx.eq.1.and.incy.eq.1)go to 20
22832 c
22833 c code for unequal increments or equal increments not equal
22834 c to 1
22835 c
22836  ix = 1
22837  iy = 1
22838  if(incx.lt.0)ix = (-n+1)*incx + 1
22839  if(incy.lt.0)iy = (-n+1)*incy + 1
22840  do 10 i = 1,n
22841  ztemp = c*zx(ix) + s*zy(iy)
22842  zy(iy) = c*zy(iy) - s*zx(ix)
22843  zx(ix) = ztemp
22844  ix = ix + incx
22845  iy = iy + incy
22846  10 continue
22847  return
22848 c
22849 c code for both increments equal to 1
22850 c
22851  20 do 30 i = 1,n
22852  ztemp = c*zx(i) + s*zy(i)
22853  zy(i) = c*zy(i) - s*zx(i)
22854  zx(i) = ztemp
22855  30 continue
22856  return
22857  end
22858  subroutine zdscal(n,da,zx,incx)
22859 c
22860 c scales a vector by a constant.
22861 c jack dongarra, 3/11/78.
22862 c modified 3/93 to return if incx .le. 0.
22863 c modified 12/3/93, array(1) declarations changed to array(*)
22864 c
22865  double complex zx(*)
22866  double precision da
22867  integer i,incx,ix,n
22868 c
22869  if( n.le.0 .or. incx.le.0 )return
22870  if(incx.eq.1)go to 20
22871 c
22872 c code for increment not equal to 1
22873 c
22874  ix = 1
22875  do 10 i = 1,n
22876  zx(ix) = dcmplx(da,0.0d0)*zx(ix)
22877  ix = ix + incx
22878  10 continue
22879  return
22880 c
22881 c code for increment equal to 1
22882 c
22883  20 do 30 i = 1,n
22884  zx(i) = dcmplx(da,0.0d0)*zx(i)
22885  30 continue
22886  return
22887  end
22888  SUBROUTINE zgbmv ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
22889  $ beta, y, incy )
22890 * .. Scalar Arguments ..
22891  COMPLEX*16 ALPHA, BETA
22892  INTEGER INCX, INCY, KL, KU, LDA, M, N
22893  CHARACTER*1 TRANS
22894 * .. Array Arguments ..
22895  COMPLEX*16 A( lda, * ), X( * ), Y( * )
22896 * ..
22897 *
22898 * Purpose
22899 * =======
22900 *
22901 * ZGBMV performs one of the matrix-vector operations
22902 *
22903 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
22904 *
22905 * y := alpha*conjg( A' )*x + beta*y,
22906 *
22907 * where alpha and beta are scalars, x and y are vectors and A is an
22908 * m by n band matrix, with kl sub-diagonals and ku super-diagonals.
22909 *
22910 * Parameters
22911 * ==========
22912 *
22913 * TRANS - CHARACTER*1.
22914 * On entry, TRANS specifies the operation to be performed as
22915 * follows:
22916 *
22917 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
22918 *
22919 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
22920 *
22921 * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
22922 *
22923 * Unchanged on exit.
22924 *
22925 * M - INTEGER.
22926 * On entry, M specifies the number of rows of the matrix A.
22927 * M must be at least zero.
22928 * Unchanged on exit.
22929 *
22930 * N - INTEGER.
22931 * On entry, N specifies the number of columns of the matrix A.
22932 * N must be at least zero.
22933 * Unchanged on exit.
22934 *
22935 * KL - INTEGER.
22936 * On entry, KL specifies the number of sub-diagonals of the
22937 * matrix A. KL must satisfy 0 .le. KL.
22938 * Unchanged on exit.
22939 *
22940 * KU - INTEGER.
22941 * On entry, KU specifies the number of super-diagonals of the
22942 * matrix A. KU must satisfy 0 .le. KU.
22943 * Unchanged on exit.
22944 *
22945 * ALPHA - COMPLEX*16 .
22946 * On entry, ALPHA specifies the scalar alpha.
22947 * Unchanged on exit.
22948 *
22949 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
22950 * Before entry, the leading ( kl + ku + 1 ) by n part of the
22951 * array A must contain the matrix of coefficients, supplied
22952 * column by column, with the leading diagonal of the matrix in
22953 * row ( ku + 1 ) of the array, the first super-diagonal
22954 * starting at position 2 in row ku, the first sub-diagonal
22955 * starting at position 1 in row ( ku + 2 ), and so on.
22956 * Elements in the array A that do not correspond to elements
22957 * in the band matrix (such as the top left ku by ku triangle)
22958 * are not referenced.
22959 * The following program segment will transfer a band matrix
22960 * from conventional full matrix storage to band storage:
22961 *
22962 * DO 20, J = 1, N
22963 * K = KU + 1 - J
22964 * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
22965 * A( K + I, J ) = matrix( I, J )
22966 * 10 CONTINUE
22967 * 20 CONTINUE
22968 *
22969 * Unchanged on exit.
22970 *
22971 * LDA - INTEGER.
22972 * On entry, LDA specifies the first dimension of A as declared
22973 * in the calling (sub) program. LDA must be at least
22974 * ( kl + ku + 1 ).
22975 * Unchanged on exit.
22976 *
22977 * X - COMPLEX*16 array of DIMENSION at least
22978 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
22979 * and at least
22980 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
22981 * Before entry, the incremented array X must contain the
22982 * vector x.
22983 * Unchanged on exit.
22984 *
22985 * INCX - INTEGER.
22986 * On entry, INCX specifies the increment for the elements of
22987 * X. INCX must not be zero.
22988 * Unchanged on exit.
22989 *
22990 * BETA - COMPLEX*16 .
22991 * On entry, BETA specifies the scalar beta. When BETA is
22992 * supplied as zero then Y need not be set on input.
22993 * Unchanged on exit.
22994 *
22995 * Y - COMPLEX*16 array of DIMENSION at least
22996 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
22997 * and at least
22998 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
22999 * Before entry, the incremented array Y must contain the
23000 * vector y. On exit, Y is overwritten by the updated vector y.
23001 *
23002 *
23003 * INCY - INTEGER.
23004 * On entry, INCY specifies the increment for the elements of
23005 * Y. INCY must not be zero.
23006 * Unchanged on exit.
23007 *
23008 *
23009 * Level 2 Blas routine.
23010 *
23011 * -- Written on 22-October-1986.
23012 * Jack Dongarra, Argonne National Lab.
23013 * Jeremy Du Croz, Nag Central Office.
23014 * Sven Hammarling, Nag Central Office.
23015 * Richard Hanson, Sandia National Labs.
23016 *
23017 *
23018 * .. Parameters ..
23019  COMPLEX*16 ONE
23020  parameter( one = ( 1.0d+0, 0.0d+0 ) )
23021  COMPLEX*16 ZERO
23022  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
23023 * .. Local Scalars ..
23024  COMPLEX*16 TEMP
23025  INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
23026  $ lenx, leny
23027  LOGICAL NOCONJ
23028 * .. External Functions ..
23029  LOGICAL LSAME
23030  EXTERNAL lsame
23031 * .. External Subroutines ..
23032  EXTERNAL xerbla
23033 * .. Intrinsic Functions ..
23034  INTRINSIC dconjg, max, min
23035 * ..
23036 * .. Executable Statements ..
23037 *
23038 * Test the input parameters.
23039 *
23040  info = 0
23041  IF ( .NOT.lsame( trans, 'N' ).AND.
23042  $ .NOT.lsame( trans, 'T' ).AND.
23043  $ .NOT.lsame( trans, 'C' ) )THEN
23044  info = 1
23045  ELSE IF( m.LT.0 )THEN
23046  info = 2
23047  ELSE IF( n.LT.0 )THEN
23048  info = 3
23049  ELSE IF( kl.LT.0 )THEN
23050  info = 4
23051  ELSE IF( ku.LT.0 )THEN
23052  info = 5
23053  ELSE IF( lda.LT.( kl + ku + 1 ) )THEN
23054  info = 8
23055  ELSE IF( incx.EQ.0 )THEN
23056  info = 10
23057  ELSE IF( incy.EQ.0 )THEN
23058  info = 13
23059  END IF
23060  IF( info.NE.0 )THEN
23061  CALL xerbla( 'ZGBMV ', info )
23062  RETURN
23063  END IF
23064 *
23065 * Quick return if possible.
23066 *
23067  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
23068  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
23069  $ RETURN
23070 *
23071  noconj = lsame( trans, 'T' )
23072 *
23073 * Set LENX and LENY, the lengths of the vectors x and y, and set
23074 * up the start points in X and Y.
23075 *
23076  IF( lsame( trans, 'N' ) )THEN
23077  lenx = n
23078  leny = m
23079  ELSE
23080  lenx = m
23081  leny = n
23082  END IF
23083  IF( incx.GT.0 )THEN
23084  kx = 1
23085  ELSE
23086  kx = 1 - ( lenx - 1 )*incx
23087  END IF
23088  IF( incy.GT.0 )THEN
23089  ky = 1
23090  ELSE
23091  ky = 1 - ( leny - 1 )*incy
23092  END IF
23093 *
23094 * Start the operations. In this version the elements of A are
23095 * accessed sequentially with one pass through the band part of A.
23096 *
23097 * First form y := beta*y.
23098 *
23099  IF( beta.NE.one )THEN
23100  IF( incy.EQ.1 )THEN
23101  IF( beta.EQ.zero )THEN
23102  DO 10, i = 1, leny
23103  y( i ) = zero
23104  10 CONTINUE
23105  ELSE
23106  DO 20, i = 1, leny
23107  y( i ) = beta*y( i )
23108  20 CONTINUE
23109  END IF
23110  ELSE
23111  iy = ky
23112  IF( beta.EQ.zero )THEN
23113  DO 30, i = 1, leny
23114  y( iy ) = zero
23115  iy = iy + incy
23116  30 CONTINUE
23117  ELSE
23118  DO 40, i = 1, leny
23119  y( iy ) = beta*y( iy )
23120  iy = iy + incy
23121  40 CONTINUE
23122  END IF
23123  END IF
23124  END IF
23125  IF( alpha.EQ.zero )
23126  $ RETURN
23127  kup1 = ku + 1
23128  IF( lsame( trans, 'N' ) )THEN
23129 *
23130 * Form y := alpha*A*x + y.
23131 *
23132  jx = kx
23133  IF( incy.EQ.1 )THEN
23134  DO 60, j = 1, n
23135  IF( x( jx ).NE.zero )THEN
23136  temp = alpha*x( jx )
23137  k = kup1 - j
23138  DO 50, i = max( 1, j - ku ), min( m, j + kl )
23139  y( i ) = y( i ) + temp*a( k + i, j )
23140  50 CONTINUE
23141  END IF
23142  jx = jx + incx
23143  60 CONTINUE
23144  ELSE
23145  DO 80, j = 1, n
23146  IF( x( jx ).NE.zero )THEN
23147  temp = alpha*x( jx )
23148  iy = ky
23149  k = kup1 - j
23150  DO 70, i = max( 1, j - ku ), min( m, j + kl )
23151  y( iy ) = y( iy ) + temp*a( k + i, j )
23152  iy = iy + incy
23153  70 CONTINUE
23154  END IF
23155  jx = jx + incx
23156  IF( j.GT.ku )
23157  $ ky = ky + incy
23158  80 CONTINUE
23159  END IF
23160  ELSE
23161 *
23162 * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
23163 *
23164  jy = ky
23165  IF( incx.EQ.1 )THEN
23166  DO 110, j = 1, n
23167  temp = zero
23168  k = kup1 - j
23169  IF( noconj )THEN
23170  DO 90, i = max( 1, j - ku ), min( m, j + kl )
23171  temp = temp + a( k + i, j )*x( i )
23172  90 CONTINUE
23173  ELSE
23174  DO 100, i = max( 1, j - ku ), min( m, j + kl )
23175  temp = temp + dconjg( a( k + i, j ) )*x( i )
23176  100 CONTINUE
23177  END IF
23178  y( jy ) = y( jy ) + alpha*temp
23179  jy = jy + incy
23180  110 CONTINUE
23181  ELSE
23182  DO 140, j = 1, n
23183  temp = zero
23184  ix = kx
23185  k = kup1 - j
23186  IF( noconj )THEN
23187  DO 120, i = max( 1, j - ku ), min( m, j + kl )
23188  temp = temp + a( k + i, j )*x( ix )
23189  ix = ix + incx
23190  120 CONTINUE
23191  ELSE
23192  DO 130, i = max( 1, j - ku ), min( m, j + kl )
23193  temp = temp + dconjg( a( k + i, j ) )*x( ix )
23194  ix = ix + incx
23195  130 CONTINUE
23196  END IF
23197  y( jy ) = y( jy ) + alpha*temp
23198  jy = jy + incy
23199  IF( j.GT.ku )
23200  $ kx = kx + incx
23201  140 CONTINUE
23202  END IF
23203  END IF
23204 *
23205  RETURN
23206 *
23207 * End of ZGBMV .
23208 *
23209  END
23210  SUBROUTINE zgemm ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
23211  $ beta, c, ldc )
23212 * .. Scalar Arguments ..
23213  CHARACTER*1 TRANSA, TRANSB
23214  INTEGER M, N, K, LDA, LDB, LDC
23215  COMPLEX*16 ALPHA, BETA
23216 * .. Array Arguments ..
23217  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
23218 * ..
23219 *
23220 * Purpose
23221 * =======
23222 *
23223 * ZGEMM performs one of the matrix-matrix operations
23224 *
23225 * C := alpha*op( A )*op( B ) + beta*C,
23226 *
23227 * where op( X ) is one of
23228 *
23229 * op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ),
23230 *
23231 * alpha and beta are scalars, and A, B and C are matrices, with op( A )
23232 * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
23233 *
23234 * Parameters
23235 * ==========
23236 *
23237 * TRANSA - CHARACTER*1.
23238 * On entry, TRANSA specifies the form of op( A ) to be used in
23239 * the matrix multiplication as follows:
23240 *
23241 * TRANSA = 'N' or 'n', op( A ) = A.
23242 *
23243 * TRANSA = 'T' or 't', op( A ) = A'.
23244 *
23245 * TRANSA = 'C' or 'c', op( A ) = conjg( A' ).
23246 *
23247 * Unchanged on exit.
23248 *
23249 * TRANSB - CHARACTER*1.
23250 * On entry, TRANSB specifies the form of op( B ) to be used in
23251 * the matrix multiplication as follows:
23252 *
23253 * TRANSB = 'N' or 'n', op( B ) = B.
23254 *
23255 * TRANSB = 'T' or 't', op( B ) = B'.
23256 *
23257 * TRANSB = 'C' or 'c', op( B ) = conjg( B' ).
23258 *
23259 * Unchanged on exit.
23260 *
23261 * M - INTEGER.
23262 * On entry, M specifies the number of rows of the matrix
23263 * op( A ) and of the matrix C. M must be at least zero.
23264 * Unchanged on exit.
23265 *
23266 * N - INTEGER.
23267 * On entry, N specifies the number of columns of the matrix
23268 * op( B ) and the number of columns of the matrix C. N must be
23269 * at least zero.
23270 * Unchanged on exit.
23271 *
23272 * K - INTEGER.
23273 * On entry, K specifies the number of columns of the matrix
23274 * op( A ) and the number of rows of the matrix op( B ). K must
23275 * be at least zero.
23276 * Unchanged on exit.
23277 *
23278 * ALPHA - COMPLEX*16 .
23279 * On entry, ALPHA specifies the scalar alpha.
23280 * Unchanged on exit.
23281 *
23282 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
23283 * k when TRANSA = 'N' or 'n', and is m otherwise.
23284 * Before entry with TRANSA = 'N' or 'n', the leading m by k
23285 * part of the array A must contain the matrix A, otherwise
23286 * the leading k by m part of the array A must contain the
23287 * matrix A.
23288 * Unchanged on exit.
23289 *
23290 * LDA - INTEGER.
23291 * On entry, LDA specifies the first dimension of A as declared
23292 * in the calling (sub) program. When TRANSA = 'N' or 'n' then
23293 * LDA must be at least max( 1, m ), otherwise LDA must be at
23294 * least max( 1, k ).
23295 * Unchanged on exit.
23296 *
23297 * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
23298 * n when TRANSB = 'N' or 'n', and is k otherwise.
23299 * Before entry with TRANSB = 'N' or 'n', the leading k by n
23300 * part of the array B must contain the matrix B, otherwise
23301 * the leading n by k part of the array B must contain the
23302 * matrix B.
23303 * Unchanged on exit.
23304 *
23305 * LDB - INTEGER.
23306 * On entry, LDB specifies the first dimension of B as declared
23307 * in the calling (sub) program. When TRANSB = 'N' or 'n' then
23308 * LDB must be at least max( 1, k ), otherwise LDB must be at
23309 * least max( 1, n ).
23310 * Unchanged on exit.
23311 *
23312 * BETA - COMPLEX*16 .
23313 * On entry, BETA specifies the scalar beta. When BETA is
23314 * supplied as zero then C need not be set on input.
23315 * Unchanged on exit.
23316 *
23317 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
23318 * Before entry, the leading m by n part of the array C must
23319 * contain the matrix C, except when beta is zero, in which
23320 * case C need not be set on entry.
23321 * On exit, the array C is overwritten by the m by n matrix
23322 * ( alpha*op( A )*op( B ) + beta*C ).
23323 *
23324 * LDC - INTEGER.
23325 * On entry, LDC specifies the first dimension of C as declared
23326 * in the calling (sub) program. LDC must be at least
23327 * max( 1, m ).
23328 * Unchanged on exit.
23329 *
23330 *
23331 * Level 3 Blas routine.
23332 *
23333 * -- Written on 8-February-1989.
23334 * Jack Dongarra, Argonne National Laboratory.
23335 * Iain Duff, AERE Harwell.
23336 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
23337 * Sven Hammarling, Numerical Algorithms Group Ltd.
23338 *
23339 *
23340 * .. External Functions ..
23341  LOGICAL LSAME
23342  EXTERNAL lsame
23343 * .. External Subroutines ..
23344  EXTERNAL xerbla
23345 * .. Intrinsic Functions ..
23346  INTRINSIC dconjg, max
23347 * .. Local Scalars ..
23348  LOGICAL CONJA, CONJB, NOTA, NOTB
23349  INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
23350  COMPLEX*16 TEMP
23351 * .. Parameters ..
23352  COMPLEX*16 ONE
23353  parameter( one = ( 1.0d+0, 0.0d+0 ) )
23354  COMPLEX*16 ZERO
23355  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
23356 * ..
23357 * .. Executable Statements ..
23358 *
23359 * Set NOTA and NOTB as true if A and B respectively are not
23360 * conjugated or transposed, set CONJA and CONJB as true if A and
23361 * B respectively are to be transposed but not conjugated and set
23362 * NROWA, NCOLA and NROWB as the number of rows and columns of A
23363 * and the number of rows of B respectively.
23364 *
23365  nota = lsame( transa, 'N' )
23366  notb = lsame( transb, 'N' )
23367  conja = lsame( transa, 'C' )
23368  conjb = lsame( transb, 'C' )
23369  IF( nota )THEN
23370  nrowa = m
23371  ncola = k
23372  ELSE
23373  nrowa = k
23374  ncola = m
23375  END IF
23376  IF( notb )THEN
23377  nrowb = k
23378  ELSE
23379  nrowb = n
23380  END IF
23381 *
23382 * Test the input parameters.
23383 *
23384  info = 0
23385  IF( ( .NOT.nota ).AND.
23386  $ ( .NOT.conja ).AND.
23387  $ ( .NOT.lsame( transa, 'T' ) ) )THEN
23388  info = 1
23389  ELSE IF( ( .NOT.notb ).AND.
23390  $ ( .NOT.conjb ).AND.
23391  $ ( .NOT.lsame( transb, 'T' ) ) )THEN
23392  info = 2
23393  ELSE IF( m .LT.0 )THEN
23394  info = 3
23395  ELSE IF( n .LT.0 )THEN
23396  info = 4
23397  ELSE IF( k .LT.0 )THEN
23398  info = 5
23399  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
23400  info = 8
23401  ELSE IF( ldb.LT.max( 1, nrowb ) )THEN
23402  info = 10
23403  ELSE IF( ldc.LT.max( 1, m ) )THEN
23404  info = 13
23405  END IF
23406  IF( info.NE.0 )THEN
23407  CALL xerbla( 'ZGEMM ', info )
23408  RETURN
23409  END IF
23410 *
23411 * Quick return if possible.
23412 *
23413  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
23414  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
23415  $ RETURN
23416 *
23417 * And when alpha.eq.zero.
23418 *
23419  IF( alpha.EQ.zero )THEN
23420  IF( beta.EQ.zero )THEN
23421  DO 20, j = 1, n
23422  DO 10, i = 1, m
23423  c( i, j ) = zero
23424  10 CONTINUE
23425  20 CONTINUE
23426  ELSE
23427  DO 40, j = 1, n
23428  DO 30, i = 1, m
23429  c( i, j ) = beta*c( i, j )
23430  30 CONTINUE
23431  40 CONTINUE
23432  END IF
23433  RETURN
23434  END IF
23435 *
23436 * Start the operations.
23437 *
23438  IF( notb )THEN
23439  IF( nota )THEN
23440 *
23441 * Form C := alpha*A*B + beta*C.
23442 *
23443  DO 90, j = 1, n
23444  IF( beta.EQ.zero )THEN
23445  DO 50, i = 1, m
23446  c( i, j ) = zero
23447  50 CONTINUE
23448  ELSE IF( beta.NE.one )THEN
23449  DO 60, i = 1, m
23450  c( i, j ) = beta*c( i, j )
23451  60 CONTINUE
23452  END IF
23453  DO 80, l = 1, k
23454  IF( b( l, j ).NE.zero )THEN
23455  temp = alpha*b( l, j )
23456  DO 70, i = 1, m
23457  c( i, j ) = c( i, j ) + temp*a( i, l )
23458  70 CONTINUE
23459  END IF
23460  80 CONTINUE
23461  90 CONTINUE
23462  ELSE IF( conja )THEN
23463 *
23464 * Form C := alpha*conjg( A' )*B + beta*C.
23465 *
23466  DO 120, j = 1, n
23467  DO 110, i = 1, m
23468  temp = zero
23469  DO 100, l = 1, k
23470  temp = temp + dconjg( a( l, i ) )*b( l, j )
23471  100 CONTINUE
23472  IF( beta.EQ.zero )THEN
23473  c( i, j ) = alpha*temp
23474  ELSE
23475  c( i, j ) = alpha*temp + beta*c( i, j )
23476  END IF
23477  110 CONTINUE
23478  120 CONTINUE
23479  ELSE
23480 *
23481 * Form C := alpha*A'*B + beta*C
23482 *
23483  DO 150, j = 1, n
23484  DO 140, i = 1, m
23485  temp = zero
23486  DO 130, l = 1, k
23487  temp = temp + a( l, i )*b( l, j )
23488  130 CONTINUE
23489  IF( beta.EQ.zero )THEN
23490  c( i, j ) = alpha*temp
23491  ELSE
23492  c( i, j ) = alpha*temp + beta*c( i, j )
23493  END IF
23494  140 CONTINUE
23495  150 CONTINUE
23496  END IF
23497  ELSE IF( nota )THEN
23498  IF( conjb )THEN
23499 *
23500 * Form C := alpha*A*conjg( B' ) + beta*C.
23501 *
23502  DO 200, j = 1, n
23503  IF( beta.EQ.zero )THEN
23504  DO 160, i = 1, m
23505  c( i, j ) = zero
23506  160 CONTINUE
23507  ELSE IF( beta.NE.one )THEN
23508  DO 170, i = 1, m
23509  c( i, j ) = beta*c( i, j )
23510  170 CONTINUE
23511  END IF
23512  DO 190, l = 1, k
23513  IF( b( j, l ).NE.zero )THEN
23514  temp = alpha*dconjg( b( j, l ) )
23515  DO 180, i = 1, m
23516  c( i, j ) = c( i, j ) + temp*a( i, l )
23517  180 CONTINUE
23518  END IF
23519  190 CONTINUE
23520  200 CONTINUE
23521  ELSE
23522 *
23523 * Form C := alpha*A*B' + beta*C
23524 *
23525  DO 250, j = 1, n
23526  IF( beta.EQ.zero )THEN
23527  DO 210, i = 1, m
23528  c( i, j ) = zero
23529  210 CONTINUE
23530  ELSE IF( beta.NE.one )THEN
23531  DO 220, i = 1, m
23532  c( i, j ) = beta*c( i, j )
23533  220 CONTINUE
23534  END IF
23535  DO 240, l = 1, k
23536  IF( b( j, l ).NE.zero )THEN
23537  temp = alpha*b( j, l )
23538  DO 230, i = 1, m
23539  c( i, j ) = c( i, j ) + temp*a( i, l )
23540  230 CONTINUE
23541  END IF
23542  240 CONTINUE
23543  250 CONTINUE
23544  END IF
23545  ELSE IF( conja )THEN
23546  IF( conjb )THEN
23547 *
23548 * Form C := alpha*conjg( A' )*conjg( B' ) + beta*C.
23549 *
23550  DO 280, j = 1, n
23551  DO 270, i = 1, m
23552  temp = zero
23553  DO 260, l = 1, k
23554  temp = temp +
23555  $ dconjg( a( l, i ) )*dconjg( b( j, l ) )
23556  260 CONTINUE
23557  IF( beta.EQ.zero )THEN
23558  c( i, j ) = alpha*temp
23559  ELSE
23560  c( i, j ) = alpha*temp + beta*c( i, j )
23561  END IF
23562  270 CONTINUE
23563  280 CONTINUE
23564  ELSE
23565 *
23566 * Form C := alpha*conjg( A' )*B' + beta*C
23567 *
23568  DO 310, j = 1, n
23569  DO 300, i = 1, m
23570  temp = zero
23571  DO 290, l = 1, k
23572  temp = temp + dconjg( a( l, i ) )*b( j, l )
23573  290 CONTINUE
23574  IF( beta.EQ.zero )THEN
23575  c( i, j ) = alpha*temp
23576  ELSE
23577  c( i, j ) = alpha*temp + beta*c( i, j )
23578  END IF
23579  300 CONTINUE
23580  310 CONTINUE
23581  END IF
23582  ELSE
23583  IF( conjb )THEN
23584 *
23585 * Form C := alpha*A'*conjg( B' ) + beta*C
23586 *
23587  DO 340, j = 1, n
23588  DO 330, i = 1, m
23589  temp = zero
23590  DO 320, l = 1, k
23591  temp = temp + a( l, i )*dconjg( b( j, l ) )
23592  320 CONTINUE
23593  IF( beta.EQ.zero )THEN
23594  c( i, j ) = alpha*temp
23595  ELSE
23596  c( i, j ) = alpha*temp + beta*c( i, j )
23597  END IF
23598  330 CONTINUE
23599  340 CONTINUE
23600  ELSE
23601 *
23602 * Form C := alpha*A'*B' + beta*C
23603 *
23604  DO 370, j = 1, n
23605  DO 360, i = 1, m
23606  temp = zero
23607  DO 350, l = 1, k
23608  temp = temp + a( l, i )*b( j, l )
23609  350 CONTINUE
23610  IF( beta.EQ.zero )THEN
23611  c( i, j ) = alpha*temp
23612  ELSE
23613  c( i, j ) = alpha*temp + beta*c( i, j )
23614  END IF
23615  360 CONTINUE
23616  370 CONTINUE
23617  END IF
23618  END IF
23619 *
23620  RETURN
23621 *
23622 * End of ZGEMM .
23623 *
23624  END
23625  SUBROUTINE zgemv ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
23626  $ beta, y, incy )
23627 * .. Scalar Arguments ..
23628  COMPLEX*16 ALPHA, BETA
23629  INTEGER INCX, INCY, LDA, M, N
23630  CHARACTER*1 TRANS
23631 * .. Array Arguments ..
23632  COMPLEX*16 A( lda, * ), X( * ), Y( * )
23633 * ..
23634 *
23635 * Purpose
23636 * =======
23637 *
23638 * ZGEMV performs one of the matrix-vector operations
23639 *
23640 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
23641 *
23642 * y := alpha*conjg( A' )*x + beta*y,
23643 *
23644 * where alpha and beta are scalars, x and y are vectors and A is an
23645 * m by n matrix.
23646 *
23647 * Parameters
23648 * ==========
23649 *
23650 * TRANS - CHARACTER*1.
23651 * On entry, TRANS specifies the operation to be performed as
23652 * follows:
23653 *
23654 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
23655 *
23656 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
23657 *
23658 * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
23659 *
23660 * Unchanged on exit.
23661 *
23662 * M - INTEGER.
23663 * On entry, M specifies the number of rows of the matrix A.
23664 * M must be at least zero.
23665 * Unchanged on exit.
23666 *
23667 * N - INTEGER.
23668 * On entry, N specifies the number of columns of the matrix A.
23669 * N must be at least zero.
23670 * Unchanged on exit.
23671 *
23672 * ALPHA - COMPLEX*16 .
23673 * On entry, ALPHA specifies the scalar alpha.
23674 * Unchanged on exit.
23675 *
23676 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
23677 * Before entry, the leading m by n part of the array A must
23678 * contain the matrix of coefficients.
23679 * Unchanged on exit.
23680 *
23681 * LDA - INTEGER.
23682 * On entry, LDA specifies the first dimension of A as declared
23683 * in the calling (sub) program. LDA must be at least
23684 * max( 1, m ).
23685 * Unchanged on exit.
23686 *
23687 * X - COMPLEX*16 array of DIMENSION at least
23688 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
23689 * and at least
23690 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
23691 * Before entry, the incremented array X must contain the
23692 * vector x.
23693 * Unchanged on exit.
23694 *
23695 * INCX - INTEGER.
23696 * On entry, INCX specifies the increment for the elements of
23697 * X. INCX must not be zero.
23698 * Unchanged on exit.
23699 *
23700 * BETA - COMPLEX*16 .
23701 * On entry, BETA specifies the scalar beta. When BETA is
23702 * supplied as zero then Y need not be set on input.
23703 * Unchanged on exit.
23704 *
23705 * Y - COMPLEX*16 array of DIMENSION at least
23706 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
23707 * and at least
23708 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
23709 * Before entry with BETA non-zero, the incremented array Y
23710 * must contain the vector y. On exit, Y is overwritten by the
23711 * updated vector y.
23712 *
23713 * INCY - INTEGER.
23714 * On entry, INCY specifies the increment for the elements of
23715 * Y. INCY must not be zero.
23716 * Unchanged on exit.
23717 *
23718 *
23719 * Level 2 Blas routine.
23720 *
23721 * -- Written on 22-October-1986.
23722 * Jack Dongarra, Argonne National Lab.
23723 * Jeremy Du Croz, Nag Central Office.
23724 * Sven Hammarling, Nag Central Office.
23725 * Richard Hanson, Sandia National Labs.
23726 *
23727 *
23728 * .. Parameters ..
23729  COMPLEX*16 ONE
23730  parameter( one = ( 1.0d+0, 0.0d+0 ) )
23731  COMPLEX*16 ZERO
23732  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
23733 * .. Local Scalars ..
23734  COMPLEX*16 TEMP
23735  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
23736  LOGICAL NOCONJ
23737 * .. External Functions ..
23738  LOGICAL LSAME
23739  EXTERNAL lsame
23740 * .. External Subroutines ..
23741  EXTERNAL xerbla
23742 * .. Intrinsic Functions ..
23743  INTRINSIC dconjg, max
23744 * ..
23745 * .. Executable Statements ..
23746 *
23747 * Test the input parameters.
23748 *
23749  info = 0
23750  IF ( .NOT.lsame( trans, 'N' ).AND.
23751  $ .NOT.lsame( trans, 'T' ).AND.
23752  $ .NOT.lsame( trans, 'C' ) )THEN
23753  info = 1
23754  ELSE IF( m.LT.0 )THEN
23755  info = 2
23756  ELSE IF( n.LT.0 )THEN
23757  info = 3
23758  ELSE IF( lda.LT.max( 1, m ) )THEN
23759  info = 6
23760  ELSE IF( incx.EQ.0 )THEN
23761  info = 8
23762  ELSE IF( incy.EQ.0 )THEN
23763  info = 11
23764  END IF
23765  IF( info.NE.0 )THEN
23766  CALL xerbla( 'ZGEMV ', info )
23767  RETURN
23768  END IF
23769 *
23770 * Quick return if possible.
23771 *
23772  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
23773  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
23774  $ RETURN
23775 *
23776  noconj = lsame( trans, 'T' )
23777 *
23778 * Set LENX and LENY, the lengths of the vectors x and y, and set
23779 * up the start points in X and Y.
23780 *
23781  IF( lsame( trans, 'N' ) )THEN
23782  lenx = n
23783  leny = m
23784  ELSE
23785  lenx = m
23786  leny = n
23787  END IF
23788  IF( incx.GT.0 )THEN
23789  kx = 1
23790  ELSE
23791  kx = 1 - ( lenx - 1 )*incx
23792  END IF
23793  IF( incy.GT.0 )THEN
23794  ky = 1
23795  ELSE
23796  ky = 1 - ( leny - 1 )*incy
23797  END IF
23798 *
23799 * Start the operations. In this version the elements of A are
23800 * accessed sequentially with one pass through A.
23801 *
23802 * First form y := beta*y.
23803 *
23804  IF( beta.NE.one )THEN
23805  IF( incy.EQ.1 )THEN
23806  IF( beta.EQ.zero )THEN
23807  DO 10, i = 1, leny
23808  y( i ) = zero
23809  10 CONTINUE
23810  ELSE
23811  DO 20, i = 1, leny
23812  y( i ) = beta*y( i )
23813  20 CONTINUE
23814  END IF
23815  ELSE
23816  iy = ky
23817  IF( beta.EQ.zero )THEN
23818  DO 30, i = 1, leny
23819  y( iy ) = zero
23820  iy = iy + incy
23821  30 CONTINUE
23822  ELSE
23823  DO 40, i = 1, leny
23824  y( iy ) = beta*y( iy )
23825  iy = iy + incy
23826  40 CONTINUE
23827  END IF
23828  END IF
23829  END IF
23830  IF( alpha.EQ.zero )
23831  $ RETURN
23832  IF( lsame( trans, 'N' ) )THEN
23833 *
23834 * Form y := alpha*A*x + y.
23835 *
23836  jx = kx
23837  IF( incy.EQ.1 )THEN
23838  DO 60, j = 1, n
23839  IF( x( jx ).NE.zero )THEN
23840  temp = alpha*x( jx )
23841  DO 50, i = 1, m
23842  y( i ) = y( i ) + temp*a( i, j )
23843  50 CONTINUE
23844  END IF
23845  jx = jx + incx
23846  60 CONTINUE
23847  ELSE
23848  DO 80, j = 1, n
23849  IF( x( jx ).NE.zero )THEN
23850  temp = alpha*x( jx )
23851  iy = ky
23852  DO 70, i = 1, m
23853  y( iy ) = y( iy ) + temp*a( i, j )
23854  iy = iy + incy
23855  70 CONTINUE
23856  END IF
23857  jx = jx + incx
23858  80 CONTINUE
23859  END IF
23860  ELSE
23861 *
23862 * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
23863 *
23864  jy = ky
23865  IF( incx.EQ.1 )THEN
23866  DO 110, j = 1, n
23867  temp = zero
23868  IF( noconj )THEN
23869  DO 90, i = 1, m
23870  temp = temp + a( i, j )*x( i )
23871  90 CONTINUE
23872  ELSE
23873  DO 100, i = 1, m
23874  temp = temp + dconjg( a( i, j ) )*x( i )
23875  100 CONTINUE
23876  END IF
23877  y( jy ) = y( jy ) + alpha*temp
23878  jy = jy + incy
23879  110 CONTINUE
23880  ELSE
23881  DO 140, j = 1, n
23882  temp = zero
23883  ix = kx
23884  IF( noconj )THEN
23885  DO 120, i = 1, m
23886  temp = temp + a( i, j )*x( ix )
23887  ix = ix + incx
23888  120 CONTINUE
23889  ELSE
23890  DO 130, i = 1, m
23891  temp = temp + dconjg( a( i, j ) )*x( ix )
23892  ix = ix + incx
23893  130 CONTINUE
23894  END IF
23895  y( jy ) = y( jy ) + alpha*temp
23896  jy = jy + incy
23897  140 CONTINUE
23898  END IF
23899  END IF
23900 *
23901  RETURN
23902 *
23903 * End of ZGEMV .
23904 *
23905  END
23906  SUBROUTINE zgerc ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
23907 * .. Scalar Arguments ..
23908  COMPLEX*16 ALPHA
23909  INTEGER INCX, INCY, LDA, M, N
23910 * .. Array Arguments ..
23911  COMPLEX*16 A( lda, * ), X( * ), Y( * )
23912 * ..
23913 *
23914 * Purpose
23915 * =======
23916 *
23917 * ZGERC performs the rank 1 operation
23918 *
23919 * A := alpha*x*conjg( y' ) + A,
23920 *
23921 * where alpha is a scalar, x is an m element vector, y is an n element
23922 * vector and A is an m by n matrix.
23923 *
23924 * Parameters
23925 * ==========
23926 *
23927 * M - INTEGER.
23928 * On entry, M specifies the number of rows of the matrix A.
23929 * M must be at least zero.
23930 * Unchanged on exit.
23931 *
23932 * N - INTEGER.
23933 * On entry, N specifies the number of columns of the matrix A.
23934 * N must be at least zero.
23935 * Unchanged on exit.
23936 *
23937 * ALPHA - COMPLEX*16 .
23938 * On entry, ALPHA specifies the scalar alpha.
23939 * Unchanged on exit.
23940 *
23941 * X - COMPLEX*16 array of dimension at least
23942 * ( 1 + ( m - 1 )*abs( INCX ) ).
23943 * Before entry, the incremented array X must contain the m
23944 * element vector x.
23945 * Unchanged on exit.
23946 *
23947 * INCX - INTEGER.
23948 * On entry, INCX specifies the increment for the elements of
23949 * X. INCX must not be zero.
23950 * Unchanged on exit.
23951 *
23952 * Y - COMPLEX*16 array of dimension at least
23953 * ( 1 + ( n - 1 )*abs( INCY ) ).
23954 * Before entry, the incremented array Y must contain the n
23955 * element vector y.
23956 * Unchanged on exit.
23957 *
23958 * INCY - INTEGER.
23959 * On entry, INCY specifies the increment for the elements of
23960 * Y. INCY must not be zero.
23961 * Unchanged on exit.
23962 *
23963 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
23964 * Before entry, the leading m by n part of the array A must
23965 * contain the matrix of coefficients. On exit, A is
23966 * overwritten by the updated matrix.
23967 *
23968 * LDA - INTEGER.
23969 * On entry, LDA specifies the first dimension of A as declared
23970 * in the calling (sub) program. LDA must be at least
23971 * max( 1, m ).
23972 * Unchanged on exit.
23973 *
23974 *
23975 * Level 2 Blas routine.
23976 *
23977 * -- Written on 22-October-1986.
23978 * Jack Dongarra, Argonne National Lab.
23979 * Jeremy Du Croz, Nag Central Office.
23980 * Sven Hammarling, Nag Central Office.
23981 * Richard Hanson, Sandia National Labs.
23982 *
23983 *
23984 * .. Parameters ..
23985  COMPLEX*16 ZERO
23986  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
23987 * .. Local Scalars ..
23988  COMPLEX*16 TEMP
23989  INTEGER I, INFO, IX, J, JY, KX
23990 * .. External Subroutines ..
23991  EXTERNAL xerbla
23992 * .. Intrinsic Functions ..
23993  INTRINSIC dconjg, max
23994 * ..
23995 * .. Executable Statements ..
23996 *
23997 * Test the input parameters.
23998 *
23999  info = 0
24000  IF ( m.LT.0 )THEN
24001  info = 1
24002  ELSE IF( n.LT.0 )THEN
24003  info = 2
24004  ELSE IF( incx.EQ.0 )THEN
24005  info = 5
24006  ELSE IF( incy.EQ.0 )THEN
24007  info = 7
24008  ELSE IF( lda.LT.max( 1, m ) )THEN
24009  info = 9
24010  END IF
24011  IF( info.NE.0 )THEN
24012  CALL xerbla( 'ZGERC ', info )
24013  RETURN
24014  END IF
24015 *
24016 * Quick return if possible.
24017 *
24018  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
24019  $ RETURN
24020 *
24021 * Start the operations. In this version the elements of A are
24022 * accessed sequentially with one pass through A.
24023 *
24024  IF( incy.GT.0 )THEN
24025  jy = 1
24026  ELSE
24027  jy = 1 - ( n - 1 )*incy
24028  END IF
24029  IF( incx.EQ.1 )THEN
24030  DO 20, j = 1, n
24031  IF( y( jy ).NE.zero )THEN
24032  temp = alpha*dconjg( y( jy ) )
24033  DO 10, i = 1, m
24034  a( i, j ) = a( i, j ) + x( i )*temp
24035  10 CONTINUE
24036  END IF
24037  jy = jy + incy
24038  20 CONTINUE
24039  ELSE
24040  IF( incx.GT.0 )THEN
24041  kx = 1
24042  ELSE
24043  kx = 1 - ( m - 1 )*incx
24044  END IF
24045  DO 40, j = 1, n
24046  IF( y( jy ).NE.zero )THEN
24047  temp = alpha*dconjg( y( jy ) )
24048  ix = kx
24049  DO 30, i = 1, m
24050  a( i, j ) = a( i, j ) + x( ix )*temp
24051  ix = ix + incx
24052  30 CONTINUE
24053  END IF
24054  jy = jy + incy
24055  40 CONTINUE
24056  END IF
24057 *
24058  RETURN
24059 *
24060 * End of ZGERC .
24061 *
24062  END
24063  SUBROUTINE zgeru ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
24064 * .. Scalar Arguments ..
24065  COMPLEX*16 ALPHA
24066  INTEGER INCX, INCY, LDA, M, N
24067 * .. Array Arguments ..
24068  COMPLEX*16 A( lda, * ), X( * ), Y( * )
24069 * ..
24070 *
24071 * Purpose
24072 * =======
24073 *
24074 * ZGERU performs the rank 1 operation
24075 *
24076 * A := alpha*x*y' + A,
24077 *
24078 * where alpha is a scalar, x is an m element vector, y is an n element
24079 * vector and A is an m by n matrix.
24080 *
24081 * Parameters
24082 * ==========
24083 *
24084 * M - INTEGER.
24085 * On entry, M specifies the number of rows of the matrix A.
24086 * M must be at least zero.
24087 * Unchanged on exit.
24088 *
24089 * N - INTEGER.
24090 * On entry, N specifies the number of columns of the matrix A.
24091 * N must be at least zero.
24092 * Unchanged on exit.
24093 *
24094 * ALPHA - COMPLEX*16 .
24095 * On entry, ALPHA specifies the scalar alpha.
24096 * Unchanged on exit.
24097 *
24098 * X - COMPLEX*16 array of dimension at least
24099 * ( 1 + ( m - 1 )*abs( INCX ) ).
24100 * Before entry, the incremented array X must contain the m
24101 * element vector x.
24102 * Unchanged on exit.
24103 *
24104 * INCX - INTEGER.
24105 * On entry, INCX specifies the increment for the elements of
24106 * X. INCX must not be zero.
24107 * Unchanged on exit.
24108 *
24109 * Y - COMPLEX*16 array of dimension at least
24110 * ( 1 + ( n - 1 )*abs( INCY ) ).
24111 * Before entry, the incremented array Y must contain the n
24112 * element vector y.
24113 * Unchanged on exit.
24114 *
24115 * INCY - INTEGER.
24116 * On entry, INCY specifies the increment for the elements of
24117 * Y. INCY must not be zero.
24118 * Unchanged on exit.
24119 *
24120 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
24121 * Before entry, the leading m by n part of the array A must
24122 * contain the matrix of coefficients. On exit, A is
24123 * overwritten by the updated matrix.
24124 *
24125 * LDA - INTEGER.
24126 * On entry, LDA specifies the first dimension of A as declared
24127 * in the calling (sub) program. LDA must be at least
24128 * max( 1, m ).
24129 * Unchanged on exit.
24130 *
24131 *
24132 * Level 2 Blas routine.
24133 *
24134 * -- Written on 22-October-1986.
24135 * Jack Dongarra, Argonne National Lab.
24136 * Jeremy Du Croz, Nag Central Office.
24137 * Sven Hammarling, Nag Central Office.
24138 * Richard Hanson, Sandia National Labs.
24139 *
24140 *
24141 * .. Parameters ..
24142  COMPLEX*16 ZERO
24143  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
24144 * .. Local Scalars ..
24145  COMPLEX*16 TEMP
24146  INTEGER I, INFO, IX, J, JY, KX
24147 * .. External Subroutines ..
24148  EXTERNAL xerbla
24149 * .. Intrinsic Functions ..
24150  INTRINSIC max
24151 * ..
24152 * .. Executable Statements ..
24153 *
24154 * Test the input parameters.
24155 *
24156  info = 0
24157  IF ( m.LT.0 )THEN
24158  info = 1
24159  ELSE IF( n.LT.0 )THEN
24160  info = 2
24161  ELSE IF( incx.EQ.0 )THEN
24162  info = 5
24163  ELSE IF( incy.EQ.0 )THEN
24164  info = 7
24165  ELSE IF( lda.LT.max( 1, m ) )THEN
24166  info = 9
24167  END IF
24168  IF( info.NE.0 )THEN
24169  CALL xerbla( 'ZGERU ', info )
24170  RETURN
24171  END IF
24172 *
24173 * Quick return if possible.
24174 *
24175  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
24176  $ RETURN
24177 *
24178 * Start the operations. In this version the elements of A are
24179 * accessed sequentially with one pass through A.
24180 *
24181  IF( incy.GT.0 )THEN
24182  jy = 1
24183  ELSE
24184  jy = 1 - ( n - 1 )*incy
24185  END IF
24186  IF( incx.EQ.1 )THEN
24187  DO 20, j = 1, n
24188  IF( y( jy ).NE.zero )THEN
24189  temp = alpha*y( jy )
24190  DO 10, i = 1, m
24191  a( i, j ) = a( i, j ) + x( i )*temp
24192  10 CONTINUE
24193  END IF
24194  jy = jy + incy
24195  20 CONTINUE
24196  ELSE
24197  IF( incx.GT.0 )THEN
24198  kx = 1
24199  ELSE
24200  kx = 1 - ( m - 1 )*incx
24201  END IF
24202  DO 40, j = 1, n
24203  IF( y( jy ).NE.zero )THEN
24204  temp = alpha*y( jy )
24205  ix = kx
24206  DO 30, i = 1, m
24207  a( i, j ) = a( i, j ) + x( ix )*temp
24208  ix = ix + incx
24209  30 CONTINUE
24210  END IF
24211  jy = jy + incy
24212  40 CONTINUE
24213  END IF
24214 *
24215  RETURN
24216 *
24217 * End of ZGERU .
24218 *
24219  END
24220  SUBROUTINE zhbmv ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
24221  $ beta, y, incy )
24222 * .. Scalar Arguments ..
24223  COMPLEX*16 ALPHA, BETA
24224  INTEGER INCX, INCY, K, LDA, N
24225  CHARACTER*1 UPLO
24226 * .. Array Arguments ..
24227  COMPLEX*16 A( lda, * ), X( * ), Y( * )
24228 * ..
24229 *
24230 * Purpose
24231 * =======
24232 *
24233 * ZHBMV performs the matrix-vector operation
24234 *
24235 * y := alpha*A*x + beta*y,
24236 *
24237 * where alpha and beta are scalars, x and y are n element vectors and
24238 * A is an n by n hermitian band matrix, with k super-diagonals.
24239 *
24240 * Parameters
24241 * ==========
24242 *
24243 * UPLO - CHARACTER*1.
24244 * On entry, UPLO specifies whether the upper or lower
24245 * triangular part of the band matrix A is being supplied as
24246 * follows:
24247 *
24248 * UPLO = 'U' or 'u' The upper triangular part of A is
24249 * being supplied.
24250 *
24251 * UPLO = 'L' or 'l' The lower triangular part of A is
24252 * being supplied.
24253 *
24254 * Unchanged on exit.
24255 *
24256 * N - INTEGER.
24257 * On entry, N specifies the order of the matrix A.
24258 * N must be at least zero.
24259 * Unchanged on exit.
24260 *
24261 * K - INTEGER.
24262 * On entry, K specifies the number of super-diagonals of the
24263 * matrix A. K must satisfy 0 .le. K.
24264 * Unchanged on exit.
24265 *
24266 * ALPHA - COMPLEX*16 .
24267 * On entry, ALPHA specifies the scalar alpha.
24268 * Unchanged on exit.
24269 *
24270 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
24271 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
24272 * by n part of the array A must contain the upper triangular
24273 * band part of the hermitian matrix, supplied column by
24274 * column, with the leading diagonal of the matrix in row
24275 * ( k + 1 ) of the array, the first super-diagonal starting at
24276 * position 2 in row k, and so on. The top left k by k triangle
24277 * of the array A is not referenced.
24278 * The following program segment will transfer the upper
24279 * triangular part of a hermitian band matrix from conventional
24280 * full matrix storage to band storage:
24281 *
24282 * DO 20, J = 1, N
24283 * M = K + 1 - J
24284 * DO 10, I = MAX( 1, J - K ), J
24285 * A( M + I, J ) = matrix( I, J )
24286 * 10 CONTINUE
24287 * 20 CONTINUE
24288 *
24289 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
24290 * by n part of the array A must contain the lower triangular
24291 * band part of the hermitian matrix, supplied column by
24292 * column, with the leading diagonal of the matrix in row 1 of
24293 * the array, the first sub-diagonal starting at position 1 in
24294 * row 2, and so on. The bottom right k by k triangle of the
24295 * array A is not referenced.
24296 * The following program segment will transfer the lower
24297 * triangular part of a hermitian band matrix from conventional
24298 * full matrix storage to band storage:
24299 *
24300 * DO 20, J = 1, N
24301 * M = 1 - J
24302 * DO 10, I = J, MIN( N, J + K )
24303 * A( M + I, J ) = matrix( I, J )
24304 * 10 CONTINUE
24305 * 20 CONTINUE
24306 *
24307 * Note that the imaginary parts of the diagonal elements need
24308 * not be set and are assumed to be zero.
24309 * Unchanged on exit.
24310 *
24311 * LDA - INTEGER.
24312 * On entry, LDA specifies the first dimension of A as declared
24313 * in the calling (sub) program. LDA must be at least
24314 * ( k + 1 ).
24315 * Unchanged on exit.
24316 *
24317 * X - COMPLEX*16 array of DIMENSION at least
24318 * ( 1 + ( n - 1 )*abs( INCX ) ).
24319 * Before entry, the incremented array X must contain the
24320 * vector x.
24321 * Unchanged on exit.
24322 *
24323 * INCX - INTEGER.
24324 * On entry, INCX specifies the increment for the elements of
24325 * X. INCX must not be zero.
24326 * Unchanged on exit.
24327 *
24328 * BETA - COMPLEX*16 .
24329 * On entry, BETA specifies the scalar beta.
24330 * Unchanged on exit.
24331 *
24332 * Y - COMPLEX*16 array of DIMENSION at least
24333 * ( 1 + ( n - 1 )*abs( INCY ) ).
24334 * Before entry, the incremented array Y must contain the
24335 * vector y. On exit, Y is overwritten by the updated vector y.
24336 *
24337 * INCY - INTEGER.
24338 * On entry, INCY specifies the increment for the elements of
24339 * Y. INCY must not be zero.
24340 * Unchanged on exit.
24341 *
24342 *
24343 * Level 2 Blas routine.
24344 *
24345 * -- Written on 22-October-1986.
24346 * Jack Dongarra, Argonne National Lab.
24347 * Jeremy Du Croz, Nag Central Office.
24348 * Sven Hammarling, Nag Central Office.
24349 * Richard Hanson, Sandia National Labs.
24350 *
24351 *
24352 * .. Parameters ..
24353  COMPLEX*16 ONE
24354  parameter( one = ( 1.0d+0, 0.0d+0 ) )
24355  COMPLEX*16 ZERO
24356  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
24357 * .. Local Scalars ..
24358  COMPLEX*16 TEMP1, TEMP2
24359  INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
24360 * .. External Functions ..
24361  LOGICAL LSAME
24362  EXTERNAL lsame
24363 * .. External Subroutines ..
24364  EXTERNAL xerbla
24365 * .. Intrinsic Functions ..
24366  INTRINSIC dconjg, max, min, dble
24367 * ..
24368 * .. Executable Statements ..
24369 *
24370 * Test the input parameters.
24371 *
24372  info = 0
24373  IF ( .NOT.lsame( uplo, 'U' ).AND.
24374  $ .NOT.lsame( uplo, 'L' ) )THEN
24375  info = 1
24376  ELSE IF( n.LT.0 )THEN
24377  info = 2
24378  ELSE IF( k.LT.0 )THEN
24379  info = 3
24380  ELSE IF( lda.LT.( k + 1 ) )THEN
24381  info = 6
24382  ELSE IF( incx.EQ.0 )THEN
24383  info = 8
24384  ELSE IF( incy.EQ.0 )THEN
24385  info = 11
24386  END IF
24387  IF( info.NE.0 )THEN
24388  CALL xerbla( 'ZHBMV ', info )
24389  RETURN
24390  END IF
24391 *
24392 * Quick return if possible.
24393 *
24394  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
24395  $ RETURN
24396 *
24397 * Set up the start points in X and Y.
24398 *
24399  IF( incx.GT.0 )THEN
24400  kx = 1
24401  ELSE
24402  kx = 1 - ( n - 1 )*incx
24403  END IF
24404  IF( incy.GT.0 )THEN
24405  ky = 1
24406  ELSE
24407  ky = 1 - ( n - 1 )*incy
24408  END IF
24409 *
24410 * Start the operations. In this version the elements of the array A
24411 * are accessed sequentially with one pass through A.
24412 *
24413 * First form y := beta*y.
24414 *
24415  IF( beta.NE.one )THEN
24416  IF( incy.EQ.1 )THEN
24417  IF( beta.EQ.zero )THEN
24418  DO 10, i = 1, n
24419  y( i ) = zero
24420  10 CONTINUE
24421  ELSE
24422  DO 20, i = 1, n
24423  y( i ) = beta*y( i )
24424  20 CONTINUE
24425  END IF
24426  ELSE
24427  iy = ky
24428  IF( beta.EQ.zero )THEN
24429  DO 30, i = 1, n
24430  y( iy ) = zero
24431  iy = iy + incy
24432  30 CONTINUE
24433  ELSE
24434  DO 40, i = 1, n
24435  y( iy ) = beta*y( iy )
24436  iy = iy + incy
24437  40 CONTINUE
24438  END IF
24439  END IF
24440  END IF
24441  IF( alpha.EQ.zero )
24442  $ RETURN
24443  IF( lsame( uplo, 'U' ) )THEN
24444 *
24445 * Form y when upper triangle of A is stored.
24446 *
24447  kplus1 = k + 1
24448  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
24449  DO 60, j = 1, n
24450  temp1 = alpha*x( j )
24451  temp2 = zero
24452  l = kplus1 - j
24453  DO 50, i = max( 1, j - k ), j - 1
24454  y( i ) = y( i ) + temp1*a( l + i, j )
24455  temp2 = temp2 + dconjg( a( l + i, j ) )*x( i )
24456  50 CONTINUE
24457  y( j ) = y( j ) + temp1*dble( a( kplus1, j ) )
24458  $ + alpha*temp2
24459  60 CONTINUE
24460  ELSE
24461  jx = kx
24462  jy = ky
24463  DO 80, j = 1, n
24464  temp1 = alpha*x( jx )
24465  temp2 = zero
24466  ix = kx
24467  iy = ky
24468  l = kplus1 - j
24469  DO 70, i = max( 1, j - k ), j - 1
24470  y( iy ) = y( iy ) + temp1*a( l + i, j )
24471  temp2 = temp2 + dconjg( a( l + i, j ) )*x( ix )
24472  ix = ix + incx
24473  iy = iy + incy
24474  70 CONTINUE
24475  y( jy ) = y( jy ) + temp1*dble( a( kplus1, j ) )
24476  $ + alpha*temp2
24477  jx = jx + incx
24478  jy = jy + incy
24479  IF( j.GT.k )THEN
24480  kx = kx + incx
24481  ky = ky + incy
24482  END IF
24483  80 CONTINUE
24484  END IF
24485  ELSE
24486 *
24487 * Form y when lower triangle of A is stored.
24488 *
24489  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
24490  DO 100, j = 1, n
24491  temp1 = alpha*x( j )
24492  temp2 = zero
24493  y( j ) = y( j ) + temp1*dble( a( 1, j ) )
24494  l = 1 - j
24495  DO 90, i = j + 1, min( n, j + k )
24496  y( i ) = y( i ) + temp1*a( l + i, j )
24497  temp2 = temp2 + dconjg( a( l + i, j ) )*x( i )
24498  90 CONTINUE
24499  y( j ) = y( j ) + alpha*temp2
24500  100 CONTINUE
24501  ELSE
24502  jx = kx
24503  jy = ky
24504  DO 120, j = 1, n
24505  temp1 = alpha*x( jx )
24506  temp2 = zero
24507  y( jy ) = y( jy ) + temp1*dble( a( 1, j ) )
24508  l = 1 - j
24509  ix = jx
24510  iy = jy
24511  DO 110, i = j + 1, min( n, j + k )
24512  ix = ix + incx
24513  iy = iy + incy
24514  y( iy ) = y( iy ) + temp1*a( l + i, j )
24515  temp2 = temp2 + dconjg( a( l + i, j ) )*x( ix )
24516  110 CONTINUE
24517  y( jy ) = y( jy ) + alpha*temp2
24518  jx = jx + incx
24519  jy = jy + incy
24520  120 CONTINUE
24521  END IF
24522  END IF
24523 *
24524  RETURN
24525 *
24526 * End of ZHBMV .
24527 *
24528  END
24529  SUBROUTINE zhemm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
24530  $ beta, c, ldc )
24531 * .. Scalar Arguments ..
24532  CHARACTER*1 SIDE, UPLO
24533  INTEGER M, N, LDA, LDB, LDC
24534  COMPLEX*16 ALPHA, BETA
24535 * .. Array Arguments ..
24536  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
24537 * ..
24538 *
24539 * Purpose
24540 * =======
24541 *
24542 * ZHEMM performs one of the matrix-matrix operations
24543 *
24544 * C := alpha*A*B + beta*C,
24545 *
24546 * or
24547 *
24548 * C := alpha*B*A + beta*C,
24549 *
24550 * where alpha and beta are scalars, A is an hermitian matrix and B and
24551 * C are m by n matrices.
24552 *
24553 * Parameters
24554 * ==========
24555 *
24556 * SIDE - CHARACTER*1.
24557 * On entry, SIDE specifies whether the hermitian matrix A
24558 * appears on the left or right in the operation as follows:
24559 *
24560 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
24561 *
24562 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
24563 *
24564 * Unchanged on exit.
24565 *
24566 * UPLO - CHARACTER*1.
24567 * On entry, UPLO specifies whether the upper or lower
24568 * triangular part of the hermitian matrix A is to be
24569 * referenced as follows:
24570 *
24571 * UPLO = 'U' or 'u' Only the upper triangular part of the
24572 * hermitian matrix is to be referenced.
24573 *
24574 * UPLO = 'L' or 'l' Only the lower triangular part of the
24575 * hermitian matrix is to be referenced.
24576 *
24577 * Unchanged on exit.
24578 *
24579 * M - INTEGER.
24580 * On entry, M specifies the number of rows of the matrix C.
24581 * M must be at least zero.
24582 * Unchanged on exit.
24583 *
24584 * N - INTEGER.
24585 * On entry, N specifies the number of columns of the matrix C.
24586 * N must be at least zero.
24587 * Unchanged on exit.
24588 *
24589 * ALPHA - COMPLEX*16 .
24590 * On entry, ALPHA specifies the scalar alpha.
24591 * Unchanged on exit.
24592 *
24593 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
24594 * m when SIDE = 'L' or 'l' and is n otherwise.
24595 * Before entry with SIDE = 'L' or 'l', the m by m part of
24596 * the array A must contain the hermitian matrix, such that
24597 * when UPLO = 'U' or 'u', the leading m by m upper triangular
24598 * part of the array A must contain the upper triangular part
24599 * of the hermitian matrix and the strictly lower triangular
24600 * part of A is not referenced, and when UPLO = 'L' or 'l',
24601 * the leading m by m lower triangular part of the array A
24602 * must contain the lower triangular part of the hermitian
24603 * matrix and the strictly upper triangular part of A is not
24604 * referenced.
24605 * Before entry with SIDE = 'R' or 'r', the n by n part of
24606 * the array A must contain the hermitian matrix, such that
24607 * when UPLO = 'U' or 'u', the leading n by n upper triangular
24608 * part of the array A must contain the upper triangular part
24609 * of the hermitian matrix and the strictly lower triangular
24610 * part of A is not referenced, and when UPLO = 'L' or 'l',
24611 * the leading n by n lower triangular part of the array A
24612 * must contain the lower triangular part of the hermitian
24613 * matrix and the strictly upper triangular part of A is not
24614 * referenced.
24615 * Note that the imaginary parts of the diagonal elements need
24616 * not be set, they are assumed to be zero.
24617 * Unchanged on exit.
24618 *
24619 * LDA - INTEGER.
24620 * On entry, LDA specifies the first dimension of A as declared
24621 * in the calling (sub) program. When SIDE = 'L' or 'l' then
24622 * LDA must be at least max( 1, m ), otherwise LDA must be at
24623 * least max( 1, n ).
24624 * Unchanged on exit.
24625 *
24626 * B - COMPLEX*16 array of DIMENSION ( LDB, n ).
24627 * Before entry, the leading m by n part of the array B must
24628 * contain the matrix B.
24629 * Unchanged on exit.
24630 *
24631 * LDB - INTEGER.
24632 * On entry, LDB specifies the first dimension of B as declared
24633 * in the calling (sub) program. LDB must be at least
24634 * max( 1, m ).
24635 * Unchanged on exit.
24636 *
24637 * BETA - COMPLEX*16 .
24638 * On entry, BETA specifies the scalar beta. When BETA is
24639 * supplied as zero then C need not be set on input.
24640 * Unchanged on exit.
24641 *
24642 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
24643 * Before entry, the leading m by n part of the array C must
24644 * contain the matrix C, except when beta is zero, in which
24645 * case C need not be set on entry.
24646 * On exit, the array C is overwritten by the m by n updated
24647 * matrix.
24648 *
24649 * LDC - INTEGER.
24650 * On entry, LDC specifies the first dimension of C as declared
24651 * in the calling (sub) program. LDC must be at least
24652 * max( 1, m ).
24653 * Unchanged on exit.
24654 *
24655 *
24656 * Level 3 Blas routine.
24657 *
24658 * -- Written on 8-February-1989.
24659 * Jack Dongarra, Argonne National Laboratory.
24660 * Iain Duff, AERE Harwell.
24661 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
24662 * Sven Hammarling, Numerical Algorithms Group Ltd.
24663 *
24664 *
24665 * .. External Functions ..
24666  LOGICAL LSAME
24667  EXTERNAL lsame
24668 * .. External Subroutines ..
24669  EXTERNAL xerbla
24670 * .. Intrinsic Functions ..
24671  INTRINSIC dconjg, max, dble
24672 * .. Local Scalars ..
24673  LOGICAL UPPER
24674  INTEGER I, INFO, J, K, NROWA
24675  COMPLEX*16 TEMP1, TEMP2
24676 * .. Parameters ..
24677  COMPLEX*16 ONE
24678  parameter( one = ( 1.0d+0, 0.0d+0 ) )
24679  COMPLEX*16 ZERO
24680  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
24681 * ..
24682 * .. Executable Statements ..
24683 *
24684 * Set NROWA as the number of rows of A.
24685 *
24686  IF( lsame( side, 'L' ) )THEN
24687  nrowa = m
24688  ELSE
24689  nrowa = n
24690  END IF
24691  upper = lsame( uplo, 'U' )
24692 *
24693 * Test the input parameters.
24694 *
24695  info = 0
24696  IF( ( .NOT.lsame( side, 'L' ) ).AND.
24697  $ ( .NOT.lsame( side, 'R' ) ) )THEN
24698  info = 1
24699  ELSE IF( ( .NOT.upper ).AND.
24700  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
24701  info = 2
24702  ELSE IF( m .LT.0 )THEN
24703  info = 3
24704  ELSE IF( n .LT.0 )THEN
24705  info = 4
24706  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
24707  info = 7
24708  ELSE IF( ldb.LT.max( 1, m ) )THEN
24709  info = 9
24710  ELSE IF( ldc.LT.max( 1, m ) )THEN
24711  info = 12
24712  END IF
24713  IF( info.NE.0 )THEN
24714  CALL xerbla( 'ZHEMM ', info )
24715  RETURN
24716  END IF
24717 *
24718 * Quick return if possible.
24719 *
24720  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
24721  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
24722  $ RETURN
24723 *
24724 * And when alpha.eq.zero.
24725 *
24726  IF( alpha.EQ.zero )THEN
24727  IF( beta.EQ.zero )THEN
24728  DO 20, j = 1, n
24729  DO 10, i = 1, m
24730  c( i, j ) = zero
24731  10 CONTINUE
24732  20 CONTINUE
24733  ELSE
24734  DO 40, j = 1, n
24735  DO 30, i = 1, m
24736  c( i, j ) = beta*c( i, j )
24737  30 CONTINUE
24738  40 CONTINUE
24739  END IF
24740  RETURN
24741  END IF
24742 *
24743 * Start the operations.
24744 *
24745  IF( lsame( side, 'L' ) )THEN
24746 *
24747 * Form C := alpha*A*B + beta*C.
24748 *
24749  IF( upper )THEN
24750  DO 70, j = 1, n
24751  DO 60, i = 1, m
24752  temp1 = alpha*b( i, j )
24753  temp2 = zero
24754  DO 50, k = 1, i - 1
24755  c( k, j ) = c( k, j ) + temp1*a( k, i )
24756  temp2 = temp2 +
24757  $ b( k, j )*dconjg( a( k, i ) )
24758  50 CONTINUE
24759  IF( beta.EQ.zero )THEN
24760  c( i, j ) = temp1*dble( a( i, i ) ) +
24761  $ alpha*temp2
24762  ELSE
24763  c( i, j ) = beta *c( i, j ) +
24764  $ temp1*dble( a( i, i ) ) +
24765  $ alpha*temp2
24766  END IF
24767  60 CONTINUE
24768  70 CONTINUE
24769  ELSE
24770  DO 100, j = 1, n
24771  DO 90, i = m, 1, -1
24772  temp1 = alpha*b( i, j )
24773  temp2 = zero
24774  DO 80, k = i + 1, m
24775  c( k, j ) = c( k, j ) + temp1*a( k, i )
24776  temp2 = temp2 +
24777  $ b( k, j )*dconjg( a( k, i ) )
24778  80 CONTINUE
24779  IF( beta.EQ.zero )THEN
24780  c( i, j ) = temp1*dble( a( i, i ) ) +
24781  $ alpha*temp2
24782  ELSE
24783  c( i, j ) = beta *c( i, j ) +
24784  $ temp1*dble( a( i, i ) ) +
24785  $ alpha*temp2
24786  END IF
24787  90 CONTINUE
24788  100 CONTINUE
24789  END IF
24790  ELSE
24791 *
24792 * Form C := alpha*B*A + beta*C.
24793 *
24794  DO 170, j = 1, n
24795  temp1 = alpha*dble( a( j, j ) )
24796  IF( beta.EQ.zero )THEN
24797  DO 110, i = 1, m
24798  c( i, j ) = temp1*b( i, j )
24799  110 CONTINUE
24800  ELSE
24801  DO 120, i = 1, m
24802  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
24803  120 CONTINUE
24804  END IF
24805  DO 140, k = 1, j - 1
24806  IF( upper )THEN
24807  temp1 = alpha*a( k, j )
24808  ELSE
24809  temp1 = alpha*dconjg( a( j, k ) )
24810  END IF
24811  DO 130, i = 1, m
24812  c( i, j ) = c( i, j ) + temp1*b( i, k )
24813  130 CONTINUE
24814  140 CONTINUE
24815  DO 160, k = j + 1, n
24816  IF( upper )THEN
24817  temp1 = alpha*dconjg( a( j, k ) )
24818  ELSE
24819  temp1 = alpha*a( k, j )
24820  END IF
24821  DO 150, i = 1, m
24822  c( i, j ) = c( i, j ) + temp1*b( i, k )
24823  150 CONTINUE
24824  160 CONTINUE
24825  170 CONTINUE
24826  END IF
24827 *
24828  RETURN
24829 *
24830 * End of ZHEMM .
24831 *
24832  END
24833  SUBROUTINE zhemv ( UPLO, N, ALPHA, A, LDA, X, INCX,
24834  $ beta, y, incy )
24835 * .. Scalar Arguments ..
24836  COMPLEX*16 ALPHA, BETA
24837  INTEGER INCX, INCY, LDA, N
24838  CHARACTER*1 UPLO
24839 * .. Array Arguments ..
24840  COMPLEX*16 A( lda, * ), X( * ), Y( * )
24841 * ..
24842 *
24843 * Purpose
24844 * =======
24845 *
24846 * ZHEMV performs the matrix-vector operation
24847 *
24848 * y := alpha*A*x + beta*y,
24849 *
24850 * where alpha and beta are scalars, x and y are n element vectors and
24851 * A is an n by n hermitian matrix.
24852 *
24853 * Parameters
24854 * ==========
24855 *
24856 * UPLO - CHARACTER*1.
24857 * On entry, UPLO specifies whether the upper or lower
24858 * triangular part of the array A is to be referenced as
24859 * follows:
24860 *
24861 * UPLO = 'U' or 'u' Only the upper triangular part of A
24862 * is to be referenced.
24863 *
24864 * UPLO = 'L' or 'l' Only the lower triangular part of A
24865 * is to be referenced.
24866 *
24867 * Unchanged on exit.
24868 *
24869 * N - INTEGER.
24870 * On entry, N specifies the order of the matrix A.
24871 * N must be at least zero.
24872 * Unchanged on exit.
24873 *
24874 * ALPHA - COMPLEX*16 .
24875 * On entry, ALPHA specifies the scalar alpha.
24876 * Unchanged on exit.
24877 *
24878 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
24879 * Before entry with UPLO = 'U' or 'u', the leading n by n
24880 * upper triangular part of the array A must contain the upper
24881 * triangular part of the hermitian matrix and the strictly
24882 * lower triangular part of A is not referenced.
24883 * Before entry with UPLO = 'L' or 'l', the leading n by n
24884 * lower triangular part of the array A must contain the lower
24885 * triangular part of the hermitian matrix and the strictly
24886 * upper triangular part of A is not referenced.
24887 * Note that the imaginary parts of the diagonal elements need
24888 * not be set and are assumed to be zero.
24889 * Unchanged on exit.
24890 *
24891 * LDA - INTEGER.
24892 * On entry, LDA specifies the first dimension of A as declared
24893 * in the calling (sub) program. LDA must be at least
24894 * max( 1, n ).
24895 * Unchanged on exit.
24896 *
24897 * X - COMPLEX*16 array of dimension at least
24898 * ( 1 + ( n - 1 )*abs( INCX ) ).
24899 * Before entry, the incremented array X must contain the n
24900 * element vector x.
24901 * Unchanged on exit.
24902 *
24903 * INCX - INTEGER.
24904 * On entry, INCX specifies the increment for the elements of
24905 * X. INCX must not be zero.
24906 * Unchanged on exit.
24907 *
24908 * BETA - COMPLEX*16 .
24909 * On entry, BETA specifies the scalar beta. When BETA is
24910 * supplied as zero then Y need not be set on input.
24911 * Unchanged on exit.
24912 *
24913 * Y - COMPLEX*16 array of dimension at least
24914 * ( 1 + ( n - 1 )*abs( INCY ) ).
24915 * Before entry, the incremented array Y must contain the n
24916 * element vector y. On exit, Y is overwritten by the updated
24917 * vector y.
24918 *
24919 * INCY - INTEGER.
24920 * On entry, INCY specifies the increment for the elements of
24921 * Y. INCY must not be zero.
24922 * Unchanged on exit.
24923 *
24924 *
24925 * Level 2 Blas routine.
24926 *
24927 * -- Written on 22-October-1986.
24928 * Jack Dongarra, Argonne National Lab.
24929 * Jeremy Du Croz, Nag Central Office.
24930 * Sven Hammarling, Nag Central Office.
24931 * Richard Hanson, Sandia National Labs.
24932 *
24933 *
24934 * .. Parameters ..
24935  COMPLEX*16 ONE
24936  parameter( one = ( 1.0d+0, 0.0d+0 ) )
24937  COMPLEX*16 ZERO
24938  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
24939 * .. Local Scalars ..
24940  COMPLEX*16 TEMP1, TEMP2
24941  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
24942 * .. External Functions ..
24943  LOGICAL LSAME
24944  EXTERNAL lsame
24945 * .. External Subroutines ..
24946  EXTERNAL xerbla
24947 * .. Intrinsic Functions ..
24948  INTRINSIC dconjg, max, dble
24949 * ..
24950 * .. Executable Statements ..
24951 *
24952 * Test the input parameters.
24953 *
24954  info = 0
24955  IF ( .NOT.lsame( uplo, 'U' ).AND.
24956  $ .NOT.lsame( uplo, 'L' ) )THEN
24957  info = 1
24958  ELSE IF( n.LT.0 )THEN
24959  info = 2
24960  ELSE IF( lda.LT.max( 1, n ) )THEN
24961  info = 5
24962  ELSE IF( incx.EQ.0 )THEN
24963  info = 7
24964  ELSE IF( incy.EQ.0 )THEN
24965  info = 10
24966  END IF
24967  IF( info.NE.0 )THEN
24968  CALL xerbla( 'ZHEMV ', info )
24969  RETURN
24970  END IF
24971 *
24972 * Quick return if possible.
24973 *
24974  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
24975  $ RETURN
24976 *
24977 * Set up the start points in X and Y.
24978 *
24979  IF( incx.GT.0 )THEN
24980  kx = 1
24981  ELSE
24982  kx = 1 - ( n - 1 )*incx
24983  END IF
24984  IF( incy.GT.0 )THEN
24985  ky = 1
24986  ELSE
24987  ky = 1 - ( n - 1 )*incy
24988  END IF
24989 *
24990 * Start the operations. In this version the elements of A are
24991 * accessed sequentially with one pass through the triangular part
24992 * of A.
24993 *
24994 * First form y := beta*y.
24995 *
24996  IF( beta.NE.one )THEN
24997  IF( incy.EQ.1 )THEN
24998  IF( beta.EQ.zero )THEN
24999  DO 10, i = 1, n
25000  y( i ) = zero
25001  10 CONTINUE
25002  ELSE
25003  DO 20, i = 1, n
25004  y( i ) = beta*y( i )
25005  20 CONTINUE
25006  END IF
25007  ELSE
25008  iy = ky
25009  IF( beta.EQ.zero )THEN
25010  DO 30, i = 1, n
25011  y( iy ) = zero
25012  iy = iy + incy
25013  30 CONTINUE
25014  ELSE
25015  DO 40, i = 1, n
25016  y( iy ) = beta*y( iy )
25017  iy = iy + incy
25018  40 CONTINUE
25019  END IF
25020  END IF
25021  END IF
25022  IF( alpha.EQ.zero )
25023  $ RETURN
25024  IF( lsame( uplo, 'U' ) )THEN
25025 *
25026 * Form y when A is stored in upper triangle.
25027 *
25028  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
25029  DO 60, j = 1, n
25030  temp1 = alpha*x( j )
25031  temp2 = zero
25032  DO 50, i = 1, j - 1
25033  y( i ) = y( i ) + temp1*a( i, j )
25034  temp2 = temp2 + dconjg( a( i, j ) )*x( i )
25035  50 CONTINUE
25036  y( j ) = y( j ) + temp1*dble( a( j, j ) ) + alpha*temp2
25037  60 CONTINUE
25038  ELSE
25039  jx = kx
25040  jy = ky
25041  DO 80, j = 1, n
25042  temp1 = alpha*x( jx )
25043  temp2 = zero
25044  ix = kx
25045  iy = ky
25046  DO 70, i = 1, j - 1
25047  y( iy ) = y( iy ) + temp1*a( i, j )
25048  temp2 = temp2 + dconjg( a( i, j ) )*x( ix )
25049  ix = ix + incx
25050  iy = iy + incy
25051  70 CONTINUE
25052  y( jy ) = y( jy ) + temp1*dble( a( j, j ) ) + alpha*temp2
25053  jx = jx + incx
25054  jy = jy + incy
25055  80 CONTINUE
25056  END IF
25057  ELSE
25058 *
25059 * Form y when A is stored in lower triangle.
25060 *
25061  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
25062  DO 100, j = 1, n
25063  temp1 = alpha*x( j )
25064  temp2 = zero
25065  y( j ) = y( j ) + temp1*dble( a( j, j ) )
25066  DO 90, i = j + 1, n
25067  y( i ) = y( i ) + temp1*a( i, j )
25068  temp2 = temp2 + dconjg( a( i, j ) )*x( i )
25069  90 CONTINUE
25070  y( j ) = y( j ) + alpha*temp2
25071  100 CONTINUE
25072  ELSE
25073  jx = kx
25074  jy = ky
25075  DO 120, j = 1, n
25076  temp1 = alpha*x( jx )
25077  temp2 = zero
25078  y( jy ) = y( jy ) + temp1*dble( a( j, j ) )
25079  ix = jx
25080  iy = jy
25081  DO 110, i = j + 1, n
25082  ix = ix + incx
25083  iy = iy + incy
25084  y( iy ) = y( iy ) + temp1*a( i, j )
25085  temp2 = temp2 + dconjg( a( i, j ) )*x( ix )
25086  110 CONTINUE
25087  y( jy ) = y( jy ) + alpha*temp2
25088  jx = jx + incx
25089  jy = jy + incy
25090  120 CONTINUE
25091  END IF
25092  END IF
25093 *
25094  RETURN
25095 *
25096 * End of ZHEMV .
25097 *
25098  END
25099  SUBROUTINE zher2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
25100 * .. Scalar Arguments ..
25101  COMPLEX*16 ALPHA
25102  INTEGER INCX, INCY, LDA, N
25103  CHARACTER*1 UPLO
25104 * .. Array Arguments ..
25105  COMPLEX*16 A( lda, * ), X( * ), Y( * )
25106 * ..
25107 *
25108 * Purpose
25109 * =======
25110 *
25111 * ZHER2 performs the hermitian rank 2 operation
25112 *
25113 * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
25114 *
25115 * where alpha is a scalar, x and y are n element vectors and A is an n
25116 * by n hermitian matrix.
25117 *
25118 * Parameters
25119 * ==========
25120 *
25121 * UPLO - CHARACTER*1.
25122 * On entry, UPLO specifies whether the upper or lower
25123 * triangular part of the array A is to be referenced as
25124 * follows:
25125 *
25126 * UPLO = 'U' or 'u' Only the upper triangular part of A
25127 * is to be referenced.
25128 *
25129 * UPLO = 'L' or 'l' Only the lower triangular part of A
25130 * is to be referenced.
25131 *
25132 * Unchanged on exit.
25133 *
25134 * N - INTEGER.
25135 * On entry, N specifies the order of the matrix A.
25136 * N must be at least zero.
25137 * Unchanged on exit.
25138 *
25139 * ALPHA - COMPLEX*16 .
25140 * On entry, ALPHA specifies the scalar alpha.
25141 * Unchanged on exit.
25142 *
25143 * X - COMPLEX*16 array of dimension at least
25144 * ( 1 + ( n - 1 )*abs( INCX ) ).
25145 * Before entry, the incremented array X must contain the n
25146 * element vector x.
25147 * Unchanged on exit.
25148 *
25149 * INCX - INTEGER.
25150 * On entry, INCX specifies the increment for the elements of
25151 * X. INCX must not be zero.
25152 * Unchanged on exit.
25153 *
25154 * Y - COMPLEX*16 array of dimension at least
25155 * ( 1 + ( n - 1 )*abs( INCY ) ).
25156 * Before entry, the incremented array Y must contain the n
25157 * element vector y.
25158 * Unchanged on exit.
25159 *
25160 * INCY - INTEGER.
25161 * On entry, INCY specifies the increment for the elements of
25162 * Y. INCY must not be zero.
25163 * Unchanged on exit.
25164 *
25165 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
25166 * Before entry with UPLO = 'U' or 'u', the leading n by n
25167 * upper triangular part of the array A must contain the upper
25168 * triangular part of the hermitian matrix and the strictly
25169 * lower triangular part of A is not referenced. On exit, the
25170 * upper triangular part of the array A is overwritten by the
25171 * upper triangular part of the updated matrix.
25172 * Before entry with UPLO = 'L' or 'l', the leading n by n
25173 * lower triangular part of the array A must contain the lower
25174 * triangular part of the hermitian matrix and the strictly
25175 * upper triangular part of A is not referenced. On exit, the
25176 * lower triangular part of the array A is overwritten by the
25177 * lower triangular part of the updated matrix.
25178 * Note that the imaginary parts of the diagonal elements need
25179 * not be set, they are assumed to be zero, and on exit they
25180 * are set to zero.
25181 *
25182 * LDA - INTEGER.
25183 * On entry, LDA specifies the first dimension of A as declared
25184 * in the calling (sub) program. LDA must be at least
25185 * max( 1, n ).
25186 * Unchanged on exit.
25187 *
25188 *
25189 * Level 2 Blas routine.
25190 *
25191 * -- Written on 22-October-1986.
25192 * Jack Dongarra, Argonne National Lab.
25193 * Jeremy Du Croz, Nag Central Office.
25194 * Sven Hammarling, Nag Central Office.
25195 * Richard Hanson, Sandia National Labs.
25196 *
25197 *
25198 * .. Parameters ..
25199  COMPLEX*16 ZERO
25200  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
25201 * .. Local Scalars ..
25202  COMPLEX*16 TEMP1, TEMP2
25203  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
25204 * .. External Functions ..
25205  LOGICAL LSAME
25206  EXTERNAL lsame
25207 * .. External Subroutines ..
25208  EXTERNAL xerbla
25209 * .. Intrinsic Functions ..
25210  INTRINSIC dconjg, max, dble
25211 * ..
25212 * .. Executable Statements ..
25213 *
25214 * Test the input parameters.
25215 *
25216  info = 0
25217  IF ( .NOT.lsame( uplo, 'U' ).AND.
25218  $ .NOT.lsame( uplo, 'L' ) )THEN
25219  info = 1
25220  ELSE IF( n.LT.0 )THEN
25221  info = 2
25222  ELSE IF( incx.EQ.0 )THEN
25223  info = 5
25224  ELSE IF( incy.EQ.0 )THEN
25225  info = 7
25226  ELSE IF( lda.LT.max( 1, n ) )THEN
25227  info = 9
25228  END IF
25229  IF( info.NE.0 )THEN
25230  CALL xerbla( 'ZHER2 ', info )
25231  RETURN
25232  END IF
25233 *
25234 * Quick return if possible.
25235 *
25236  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
25237  $ RETURN
25238 *
25239 * Set up the start points in X and Y if the increments are not both
25240 * unity.
25241 *
25242  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
25243  IF( incx.GT.0 )THEN
25244  kx = 1
25245  ELSE
25246  kx = 1 - ( n - 1 )*incx
25247  END IF
25248  IF( incy.GT.0 )THEN
25249  ky = 1
25250  ELSE
25251  ky = 1 - ( n - 1 )*incy
25252  END IF
25253  jx = kx
25254  jy = ky
25255  END IF
25256 *
25257 * Start the operations. In this version the elements of A are
25258 * accessed sequentially with one pass through the triangular part
25259 * of A.
25260 *
25261  IF( lsame( uplo, 'U' ) )THEN
25262 *
25263 * Form A when A is stored in the upper triangle.
25264 *
25265  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
25266  DO 20, j = 1, n
25267  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
25268  temp1 = alpha*dconjg( y( j ) )
25269  temp2 = dconjg( alpha*x( j ) )
25270  DO 10, i = 1, j - 1
25271  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
25272  10 CONTINUE
25273  a( j, j ) = dble( a( j, j ) ) +
25274  $ dble( x( j )*temp1 + y( j )*temp2 )
25275  ELSE
25276  a( j, j ) = dble( a( j, j ) )
25277  END IF
25278  20 CONTINUE
25279  ELSE
25280  DO 40, j = 1, n
25281  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
25282  temp1 = alpha*dconjg( y( jy ) )
25283  temp2 = dconjg( alpha*x( jx ) )
25284  ix = kx
25285  iy = ky
25286  DO 30, i = 1, j - 1
25287  a( i, j ) = a( i, j ) + x( ix )*temp1
25288  $ + y( iy )*temp2
25289  ix = ix + incx
25290  iy = iy + incy
25291  30 CONTINUE
25292  a( j, j ) = dble( a( j, j ) ) +
25293  $ dble( x( jx )*temp1 + y( jy )*temp2 )
25294  ELSE
25295  a( j, j ) = dble( a( j, j ) )
25296  END IF
25297  jx = jx + incx
25298  jy = jy + incy
25299  40 CONTINUE
25300  END IF
25301  ELSE
25302 *
25303 * Form A when A is stored in the lower triangle.
25304 *
25305  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
25306  DO 60, j = 1, n
25307  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
25308  temp1 = alpha*dconjg( y( j ) )
25309  temp2 = dconjg( alpha*x( j ) )
25310  a( j, j ) = dble( a( j, j ) ) +
25311  $ dble( x( j )*temp1 + y( j )*temp2 )
25312  DO 50, i = j + 1, n
25313  a( i, j ) = a( i, j ) + x( i )*temp1 + y( i )*temp2
25314  50 CONTINUE
25315  ELSE
25316  a( j, j ) = dble( a( j, j ) )
25317  END IF
25318  60 CONTINUE
25319  ELSE
25320  DO 80, j = 1, n
25321  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
25322  temp1 = alpha*dconjg( y( jy ) )
25323  temp2 = dconjg( alpha*x( jx ) )
25324  a( j, j ) = dble( a( j, j ) ) +
25325  $ dble( x( jx )*temp1 + y( jy )*temp2 )
25326  ix = jx
25327  iy = jy
25328  DO 70, i = j + 1, n
25329  ix = ix + incx
25330  iy = iy + incy
25331  a( i, j ) = a( i, j ) + x( ix )*temp1
25332  $ + y( iy )*temp2
25333  70 CONTINUE
25334  ELSE
25335  a( j, j ) = dble( a( j, j ) )
25336  END IF
25337  jx = jx + incx
25338  jy = jy + incy
25339  80 CONTINUE
25340  END IF
25341  END IF
25342 *
25343  RETURN
25344 *
25345 * End of ZHER2 .
25346 *
25347  END
25348  SUBROUTINE zher2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA,
25349  $ c, ldc )
25350 * .. Scalar Arguments ..
25351  CHARACTER TRANS, UPLO
25352  INTEGER K, LDA, LDB, LDC, N
25353  DOUBLE PRECISION BETA
25354  COMPLEX*16 ALPHA
25355 * ..
25356 * .. Array Arguments ..
25357  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
25358 * ..
25359 *
25360 * Purpose
25361 * =======
25362 *
25363 * ZHER2K performs one of the hermitian rank 2k operations
25364 *
25365 * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C,
25366 *
25367 * or
25368 *
25369 * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C,
25370 *
25371 * where alpha and beta are scalars with beta real, C is an n by n
25372 * hermitian matrix and A and B are n by k matrices in the first case
25373 * and k by n matrices in the second case.
25374 *
25375 * Parameters
25376 * ==========
25377 *
25378 * UPLO - CHARACTER*1.
25379 * On entry, UPLO specifies whether the upper or lower
25380 * triangular part of the array C is to be referenced as
25381 * follows:
25382 *
25383 * UPLO = 'U' or 'u' Only the upper triangular part of C
25384 * is to be referenced.
25385 *
25386 * UPLO = 'L' or 'l' Only the lower triangular part of C
25387 * is to be referenced.
25388 *
25389 * Unchanged on exit.
25390 *
25391 * TRANS - CHARACTER*1.
25392 * On entry, TRANS specifies the operation to be performed as
25393 * follows:
25394 *
25395 * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) +
25396 * conjg( alpha )*B*conjg( A' ) +
25397 * beta*C.
25398 *
25399 * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B +
25400 * conjg( alpha )*conjg( B' )*A +
25401 * beta*C.
25402 *
25403 * Unchanged on exit.
25404 *
25405 * N - INTEGER.
25406 * On entry, N specifies the order of the matrix C. N must be
25407 * at least zero.
25408 * Unchanged on exit.
25409 *
25410 * K - INTEGER.
25411 * On entry with TRANS = 'N' or 'n', K specifies the number
25412 * of columns of the matrices A and B, and on entry with
25413 * TRANS = 'C' or 'c', K specifies the number of rows of the
25414 * matrices A and B. K must be at least zero.
25415 * Unchanged on exit.
25416 *
25417 * ALPHA - COMPLEX*16 .
25418 * On entry, ALPHA specifies the scalar alpha.
25419 * Unchanged on exit.
25420 *
25421 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
25422 * k when TRANS = 'N' or 'n', and is n otherwise.
25423 * Before entry with TRANS = 'N' or 'n', the leading n by k
25424 * part of the array A must contain the matrix A, otherwise
25425 * the leading k by n part of the array A must contain the
25426 * matrix A.
25427 * Unchanged on exit.
25428 *
25429 * LDA - INTEGER.
25430 * On entry, LDA specifies the first dimension of A as declared
25431 * in the calling (sub) program. When TRANS = 'N' or 'n'
25432 * then LDA must be at least max( 1, n ), otherwise LDA must
25433 * be at least max( 1, k ).
25434 * Unchanged on exit.
25435 *
25436 * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
25437 * k when TRANS = 'N' or 'n', and is n otherwise.
25438 * Before entry with TRANS = 'N' or 'n', the leading n by k
25439 * part of the array B must contain the matrix B, otherwise
25440 * the leading k by n part of the array B must contain the
25441 * matrix B.
25442 * Unchanged on exit.
25443 *
25444 * LDB - INTEGER.
25445 * On entry, LDB specifies the first dimension of B as declared
25446 * in the calling (sub) program. When TRANS = 'N' or 'n'
25447 * then LDB must be at least max( 1, n ), otherwise LDB must
25448 * be at least max( 1, k ).
25449 * Unchanged on exit.
25450 *
25451 * BETA - DOUBLE PRECISION .
25452 * On entry, BETA specifies the scalar beta.
25453 * Unchanged on exit.
25454 *
25455 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
25456 * Before entry with UPLO = 'U' or 'u', the leading n by n
25457 * upper triangular part of the array C must contain the upper
25458 * triangular part of the hermitian matrix and the strictly
25459 * lower triangular part of C is not referenced. On exit, the
25460 * upper triangular part of the array C is overwritten by the
25461 * upper triangular part of the updated matrix.
25462 * Before entry with UPLO = 'L' or 'l', the leading n by n
25463 * lower triangular part of the array C must contain the lower
25464 * triangular part of the hermitian matrix and the strictly
25465 * upper triangular part of C is not referenced. On exit, the
25466 * lower triangular part of the array C is overwritten by the
25467 * lower triangular part of the updated matrix.
25468 * Note that the imaginary parts of the diagonal elements need
25469 * not be set, they are assumed to be zero, and on exit they
25470 * are set to zero.
25471 *
25472 * LDC - INTEGER.
25473 * On entry, LDC specifies the first dimension of C as declared
25474 * in the calling (sub) program. LDC must be at least
25475 * max( 1, n ).
25476 * Unchanged on exit.
25477 *
25478 *
25479 * Level 3 Blas routine.
25480 *
25481 * -- Written on 8-February-1989.
25482 * Jack Dongarra, Argonne National Laboratory.
25483 * Iain Duff, AERE Harwell.
25484 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
25485 * Sven Hammarling, Numerical Algorithms Group Ltd.
25486 *
25487 * -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
25488 * Ed Anderson, Cray Research Inc.
25489 *
25490 *
25491 * .. External Functions ..
25492  LOGICAL LSAME
25493  EXTERNAL lsame
25494 * ..
25495 * .. External Subroutines ..
25496  EXTERNAL xerbla
25497 * ..
25498 * .. Intrinsic Functions ..
25499  INTRINSIC dble, dconjg, max
25500 * ..
25501 * .. Local Scalars ..
25502  LOGICAL UPPER
25503  INTEGER I, INFO, J, L, NROWA
25504  COMPLEX*16 TEMP1, TEMP2
25505 * ..
25506 * .. Parameters ..
25507  DOUBLE PRECISION ONE
25508  parameter( one = 1.0d+0 )
25509  COMPLEX*16 ZERO
25510  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
25511 * ..
25512 * .. Executable Statements ..
25513 *
25514 * Test the input parameters.
25515 *
25516  IF( lsame( trans, 'N' ) ) THEN
25517  nrowa = n
25518  ELSE
25519  nrowa = k
25520  END IF
25521  upper = lsame( uplo, 'U' )
25522 *
25523  info = 0
25524  IF( ( .NOT.upper ) .AND. ( .NOT.lsame( uplo, 'L' ) ) ) THEN
25525  info = 1
25526  ELSE IF( ( .NOT.lsame( trans, 'N' ) ) .AND.
25527  $ ( .NOT.lsame( trans, 'C' ) ) ) THEN
25528  info = 2
25529  ELSE IF( n.LT.0 ) THEN
25530  info = 3
25531  ELSE IF( k.LT.0 ) THEN
25532  info = 4
25533  ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
25534  info = 7
25535  ELSE IF( ldb.LT.max( 1, nrowa ) ) THEN
25536  info = 9
25537  ELSE IF( ldc.LT.max( 1, n ) ) THEN
25538  info = 12
25539  END IF
25540  IF( info.NE.0 ) THEN
25541  CALL xerbla( 'ZHER2K', info )
25542  RETURN
25543  END IF
25544 *
25545 * Quick return if possible.
25546 *
25547  IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
25548  $ ( beta.EQ.one ) ) )RETURN
25549 *
25550 * And when alpha.eq.zero.
25551 *
25552  IF( alpha.EQ.zero ) THEN
25553  IF( upper ) THEN
25554  IF( beta.EQ.dble( zero ) ) THEN
25555  DO 20 j = 1, n
25556  DO 10 i = 1, j
25557  c( i, j ) = zero
25558  10 CONTINUE
25559  20 CONTINUE
25560  ELSE
25561  DO 40 j = 1, n
25562  DO 30 i = 1, j - 1
25563  c( i, j ) = beta*c( i, j )
25564  30 CONTINUE
25565  c( j, j ) = beta*dble( c( j, j ) )
25566  40 CONTINUE
25567  END IF
25568  ELSE
25569  IF( beta.EQ.dble( zero ) ) THEN
25570  DO 60 j = 1, n
25571  DO 50 i = j, n
25572  c( i, j ) = zero
25573  50 CONTINUE
25574  60 CONTINUE
25575  ELSE
25576  DO 80 j = 1, n
25577  c( j, j ) = beta*dble( c( j, j ) )
25578  DO 70 i = j + 1, n
25579  c( i, j ) = beta*c( i, j )
25580  70 CONTINUE
25581  80 CONTINUE
25582  END IF
25583  END IF
25584  RETURN
25585  END IF
25586 *
25587 * Start the operations.
25588 *
25589  IF( lsame( trans, 'N' ) ) THEN
25590 *
25591 * Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) +
25592 * C.
25593 *
25594  IF( upper ) THEN
25595  DO 130 j = 1, n
25596  IF( beta.EQ.dble( zero ) ) THEN
25597  DO 90 i = 1, j
25598  c( i, j ) = zero
25599  90 CONTINUE
25600  ELSE IF( beta.NE.one ) THEN
25601  DO 100 i = 1, j - 1
25602  c( i, j ) = beta*c( i, j )
25603  100 CONTINUE
25604  c( j, j ) = beta*dble( c( j, j ) )
25605  ELSE
25606  c( j, j ) = dble( c( j, j ) )
25607  END IF
25608  DO 120 l = 1, k
25609  IF( ( a( j, l ).NE.zero ) .OR. ( b( j, l ).NE.zero ) )
25610  $ THEN
25611  temp1 = alpha*dconjg( b( j, l ) )
25612  temp2 = dconjg( alpha*a( j, l ) )
25613  DO 110 i = 1, j - 1
25614  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
25615  $ b( i, l )*temp2
25616  110 CONTINUE
25617  c( j, j ) = dble( c( j, j ) ) +
25618  $ dble( a( j, l )*temp1+b( j, l )*temp2 )
25619  END IF
25620  120 CONTINUE
25621  130 CONTINUE
25622  ELSE
25623  DO 180 j = 1, n
25624  IF( beta.EQ.dble( zero ) ) THEN
25625  DO 140 i = j, n
25626  c( i, j ) = zero
25627  140 CONTINUE
25628  ELSE IF( beta.NE.one ) THEN
25629  DO 150 i = j + 1, n
25630  c( i, j ) = beta*c( i, j )
25631  150 CONTINUE
25632  c( j, j ) = beta*dble( c( j, j ) )
25633  ELSE
25634  c( j, j ) = dble( c( j, j ) )
25635  END IF
25636  DO 170 l = 1, k
25637  IF( ( a( j, l ).NE.zero ) .OR. ( b( j, l ).NE.zero ) )
25638  $ THEN
25639  temp1 = alpha*dconjg( b( j, l ) )
25640  temp2 = dconjg( alpha*a( j, l ) )
25641  DO 160 i = j + 1, n
25642  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
25643  $ b( i, l )*temp2
25644  160 CONTINUE
25645  c( j, j ) = dble( c( j, j ) ) +
25646  $ dble( a( j, l )*temp1+b( j, l )*temp2 )
25647  END IF
25648  170 CONTINUE
25649  180 CONTINUE
25650  END IF
25651  ELSE
25652 *
25653 * Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A +
25654 * C.
25655 *
25656  IF( upper ) THEN
25657  DO 210 j = 1, n
25658  DO 200 i = 1, j
25659  temp1 = zero
25660  temp2 = zero
25661  DO 190 l = 1, k
25662  temp1 = temp1 + dconjg( a( l, i ) )*b( l, j )
25663  temp2 = temp2 + dconjg( b( l, i ) )*a( l, j )
25664  190 CONTINUE
25665  IF( i.EQ.j ) THEN
25666  IF( beta.EQ.dble( zero ) ) THEN
25667  c( j, j ) = dble( alpha*temp1+dconjg( alpha )*
25668  $ temp2 )
25669  ELSE
25670  c( j, j ) = beta*dble( c( j, j ) ) +
25671  $ dble( alpha*temp1+dconjg( alpha )*
25672  $ temp2 )
25673  END IF
25674  ELSE
25675  IF( beta.EQ.dble( zero ) ) THEN
25676  c( i, j ) = alpha*temp1 + dconjg( alpha )*temp2
25677  ELSE
25678  c( i, j ) = beta*c( i, j ) + alpha*temp1 +
25679  $ dconjg( alpha )*temp2
25680  END IF
25681  END IF
25682  200 CONTINUE
25683  210 CONTINUE
25684  ELSE
25685  DO 240 j = 1, n
25686  DO 230 i = j, n
25687  temp1 = zero
25688  temp2 = zero
25689  DO 220 l = 1, k
25690  temp1 = temp1 + dconjg( a( l, i ) )*b( l, j )
25691  temp2 = temp2 + dconjg( b( l, i ) )*a( l, j )
25692  220 CONTINUE
25693  IF( i.EQ.j ) THEN
25694  IF( beta.EQ.dble( zero ) ) THEN
25695  c( j, j ) = dble( alpha*temp1+dconjg( alpha )*
25696  $ temp2 )
25697  ELSE
25698  c( j, j ) = beta*dble( c( j, j ) ) +
25699  $ dble( alpha*temp1+dconjg( alpha )*
25700  $ temp2 )
25701  END IF
25702  ELSE
25703  IF( beta.EQ.dble( zero ) ) THEN
25704  c( i, j ) = alpha*temp1 + dconjg( alpha )*temp2
25705  ELSE
25706  c( i, j ) = beta*c( i, j ) + alpha*temp1 +
25707  $ dconjg( alpha )*temp2
25708  END IF
25709  END IF
25710  230 CONTINUE
25711  240 CONTINUE
25712  END IF
25713  END IF
25714 *
25715  RETURN
25716 *
25717 * End of ZHER2K.
25718 *
25719  END
25720  SUBROUTINE zher ( UPLO, N, ALPHA, X, INCX, A, LDA )
25721 * .. Scalar Arguments ..
25722  DOUBLE PRECISION ALPHA
25723  INTEGER INCX, LDA, N
25724  CHARACTER*1 UPLO
25725 * .. Array Arguments ..
25726  COMPLEX*16 A( lda, * ), X( * )
25727 * ..
25728 *
25729 * Purpose
25730 * =======
25731 *
25732 * ZHER performs the hermitian rank 1 operation
25733 *
25734 * A := alpha*x*conjg( x' ) + A,
25735 *
25736 * where alpha is a real scalar, x is an n element vector and A is an
25737 * n by n hermitian matrix.
25738 *
25739 * Parameters
25740 * ==========
25741 *
25742 * UPLO - CHARACTER*1.
25743 * On entry, UPLO specifies whether the upper or lower
25744 * triangular part of the array A is to be referenced as
25745 * follows:
25746 *
25747 * UPLO = 'U' or 'u' Only the upper triangular part of A
25748 * is to be referenced.
25749 *
25750 * UPLO = 'L' or 'l' Only the lower triangular part of A
25751 * is to be referenced.
25752 *
25753 * Unchanged on exit.
25754 *
25755 * N - INTEGER.
25756 * On entry, N specifies the order of the matrix A.
25757 * N must be at least zero.
25758 * Unchanged on exit.
25759 *
25760 * ALPHA - DOUBLE PRECISION.
25761 * On entry, ALPHA specifies the scalar alpha.
25762 * Unchanged on exit.
25763 *
25764 * X - COMPLEX*16 array of dimension at least
25765 * ( 1 + ( n - 1 )*abs( INCX ) ).
25766 * Before entry, the incremented array X must contain the n
25767 * element vector x.
25768 * Unchanged on exit.
25769 *
25770 * INCX - INTEGER.
25771 * On entry, INCX specifies the increment for the elements of
25772 * X. INCX must not be zero.
25773 * Unchanged on exit.
25774 *
25775 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
25776 * Before entry with UPLO = 'U' or 'u', the leading n by n
25777 * upper triangular part of the array A must contain the upper
25778 * triangular part of the hermitian matrix and the strictly
25779 * lower triangular part of A is not referenced. On exit, the
25780 * upper triangular part of the array A is overwritten by the
25781 * upper triangular part of the updated matrix.
25782 * Before entry with UPLO = 'L' or 'l', the leading n by n
25783 * lower triangular part of the array A must contain the lower
25784 * triangular part of the hermitian matrix and the strictly
25785 * upper triangular part of A is not referenced. On exit, the
25786 * lower triangular part of the array A is overwritten by the
25787 * lower triangular part of the updated matrix.
25788 * Note that the imaginary parts of the diagonal elements need
25789 * not be set, they are assumed to be zero, and on exit they
25790 * are set to zero.
25791 *
25792 * LDA - INTEGER.
25793 * On entry, LDA specifies the first dimension of A as declared
25794 * in the calling (sub) program. LDA must be at least
25795 * max( 1, n ).
25796 * Unchanged on exit.
25797 *
25798 *
25799 * Level 2 Blas routine.
25800 *
25801 * -- Written on 22-October-1986.
25802 * Jack Dongarra, Argonne National Lab.
25803 * Jeremy Du Croz, Nag Central Office.
25804 * Sven Hammarling, Nag Central Office.
25805 * Richard Hanson, Sandia National Labs.
25806 *
25807 *
25808 * .. Parameters ..
25809  COMPLEX*16 ZERO
25810  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
25811 * .. Local Scalars ..
25812  COMPLEX*16 TEMP
25813  INTEGER I, INFO, IX, J, JX, KX
25814 * .. External Functions ..
25815  LOGICAL LSAME
25816  EXTERNAL lsame
25817 * .. External Subroutines ..
25818  EXTERNAL xerbla
25819 * .. Intrinsic Functions ..
25820  INTRINSIC dconjg, max, dble
25821 * ..
25822 * .. Executable Statements ..
25823 *
25824 * Test the input parameters.
25825 *
25826  info = 0
25827  IF ( .NOT.lsame( uplo, 'U' ).AND.
25828  $ .NOT.lsame( uplo, 'L' ) )THEN
25829  info = 1
25830  ELSE IF( n.LT.0 )THEN
25831  info = 2
25832  ELSE IF( incx.EQ.0 )THEN
25833  info = 5
25834  ELSE IF( lda.LT.max( 1, n ) )THEN
25835  info = 7
25836  END IF
25837  IF( info.NE.0 )THEN
25838  CALL xerbla( 'ZHER ', info )
25839  RETURN
25840  END IF
25841 *
25842 * Quick return if possible.
25843 *
25844  IF( ( n.EQ.0 ).OR.( alpha.EQ.dble( zero ) ) )
25845  $ RETURN
25846 *
25847 * Set the start point in X if the increment is not unity.
25848 *
25849  IF( incx.LE.0 )THEN
25850  kx = 1 - ( n - 1 )*incx
25851  ELSE IF( incx.NE.1 )THEN
25852  kx = 1
25853  END IF
25854 *
25855 * Start the operations. In this version the elements of A are
25856 * accessed sequentially with one pass through the triangular part
25857 * of A.
25858 *
25859  IF( lsame( uplo, 'U' ) )THEN
25860 *
25861 * Form A when A is stored in upper triangle.
25862 *
25863  IF( incx.EQ.1 )THEN
25864  DO 20, j = 1, n
25865  IF( x( j ).NE.zero )THEN
25866  temp = alpha*dconjg( x( j ) )
25867  DO 10, i = 1, j - 1
25868  a( i, j ) = a( i, j ) + x( i )*temp
25869  10 CONTINUE
25870  a( j, j ) = dble( a( j, j ) ) + dble( x( j )*temp )
25871  ELSE
25872  a( j, j ) = dble( a( j, j ) )
25873  END IF
25874  20 CONTINUE
25875  ELSE
25876  jx = kx
25877  DO 40, j = 1, n
25878  IF( x( jx ).NE.zero )THEN
25879  temp = alpha*dconjg( x( jx ) )
25880  ix = kx
25881  DO 30, i = 1, j - 1
25882  a( i, j ) = a( i, j ) + x( ix )*temp
25883  ix = ix + incx
25884  30 CONTINUE
25885  a( j, j ) = dble( a( j, j ) ) + dble( x( jx )*temp )
25886  ELSE
25887  a( j, j ) = dble( a( j, j ) )
25888  END IF
25889  jx = jx + incx
25890  40 CONTINUE
25891  END IF
25892  ELSE
25893 *
25894 * Form A when A is stored in lower triangle.
25895 *
25896  IF( incx.EQ.1 )THEN
25897  DO 60, j = 1, n
25898  IF( x( j ).NE.zero )THEN
25899  temp = alpha*dconjg( x( j ) )
25900  a( j, j ) = dble( a( j, j ) ) + dble( temp*x( j ) )
25901  DO 50, i = j + 1, n
25902  a( i, j ) = a( i, j ) + x( i )*temp
25903  50 CONTINUE
25904  ELSE
25905  a( j, j ) = dble( a( j, j ) )
25906  END IF
25907  60 CONTINUE
25908  ELSE
25909  jx = kx
25910  DO 80, j = 1, n
25911  IF( x( jx ).NE.zero )THEN
25912  temp = alpha*dconjg( x( jx ) )
25913  a( j, j ) = dble( a( j, j ) ) + dble( temp*x( jx ) )
25914  ix = jx
25915  DO 70, i = j + 1, n
25916  ix = ix + incx
25917  a( i, j ) = a( i, j ) + x( ix )*temp
25918  70 CONTINUE
25919  ELSE
25920  a( j, j ) = dble( a( j, j ) )
25921  END IF
25922  jx = jx + incx
25923  80 CONTINUE
25924  END IF
25925  END IF
25926 *
25927  RETURN
25928 *
25929 * End of ZHER .
25930 *
25931  END
25932  SUBROUTINE zherk( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC )
25933 * .. Scalar Arguments ..
25934  CHARACTER TRANS, UPLO
25935  INTEGER K, LDA, LDC, N
25936  DOUBLE PRECISION ALPHA, BETA
25937 * ..
25938 * .. Array Arguments ..
25939  COMPLEX*16 A( lda, * ), C( ldc, * )
25940 * ..
25941 *
25942 * Purpose
25943 * =======
25944 *
25945 * ZHERK performs one of the hermitian rank k operations
25946 *
25947 * C := alpha*A*conjg( A' ) + beta*C,
25948 *
25949 * or
25950 *
25951 * C := alpha*conjg( A' )*A + beta*C,
25952 *
25953 * where alpha and beta are real scalars, C is an n by n hermitian
25954 * matrix and A is an n by k matrix in the first case and a k by n
25955 * matrix in the second case.
25956 *
25957 * Parameters
25958 * ==========
25959 *
25960 * UPLO - CHARACTER*1.
25961 * On entry, UPLO specifies whether the upper or lower
25962 * triangular part of the array C is to be referenced as
25963 * follows:
25964 *
25965 * UPLO = 'U' or 'u' Only the upper triangular part of C
25966 * is to be referenced.
25967 *
25968 * UPLO = 'L' or 'l' Only the lower triangular part of C
25969 * is to be referenced.
25970 *
25971 * Unchanged on exit.
25972 *
25973 * TRANS - CHARACTER*1.
25974 * On entry, TRANS specifies the operation to be performed as
25975 * follows:
25976 *
25977 * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.
25978 *
25979 * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.
25980 *
25981 * Unchanged on exit.
25982 *
25983 * N - INTEGER.
25984 * On entry, N specifies the order of the matrix C. N must be
25985 * at least zero.
25986 * Unchanged on exit.
25987 *
25988 * K - INTEGER.
25989 * On entry with TRANS = 'N' or 'n', K specifies the number
25990 * of columns of the matrix A, and on entry with
25991 * TRANS = 'C' or 'c', K specifies the number of rows of the
25992 * matrix A. K must be at least zero.
25993 * Unchanged on exit.
25994 *
25995 * ALPHA - DOUBLE PRECISION .
25996 * On entry, ALPHA specifies the scalar alpha.
25997 * Unchanged on exit.
25998 *
25999 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
26000 * k when TRANS = 'N' or 'n', and is n otherwise.
26001 * Before entry with TRANS = 'N' or 'n', the leading n by k
26002 * part of the array A must contain the matrix A, otherwise
26003 * the leading k by n part of the array A must contain the
26004 * matrix A.
26005 * Unchanged on exit.
26006 *
26007 * LDA - INTEGER.
26008 * On entry, LDA specifies the first dimension of A as declared
26009 * in the calling (sub) program. When TRANS = 'N' or 'n'
26010 * then LDA must be at least max( 1, n ), otherwise LDA must
26011 * be at least max( 1, k ).
26012 * Unchanged on exit.
26013 *
26014 * BETA - DOUBLE PRECISION.
26015 * On entry, BETA specifies the scalar beta.
26016 * Unchanged on exit.
26017 *
26018 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
26019 * Before entry with UPLO = 'U' or 'u', the leading n by n
26020 * upper triangular part of the array C must contain the upper
26021 * triangular part of the hermitian matrix and the strictly
26022 * lower triangular part of C is not referenced. On exit, the
26023 * upper triangular part of the array C is overwritten by the
26024 * upper triangular part of the updated matrix.
26025 * Before entry with UPLO = 'L' or 'l', the leading n by n
26026 * lower triangular part of the array C must contain the lower
26027 * triangular part of the hermitian matrix and the strictly
26028 * upper triangular part of C is not referenced. On exit, the
26029 * lower triangular part of the array C is overwritten by the
26030 * lower triangular part of the updated matrix.
26031 * Note that the imaginary parts of the diagonal elements need
26032 * not be set, they are assumed to be zero, and on exit they
26033 * are set to zero.
26034 *
26035 * LDC - INTEGER.
26036 * On entry, LDC specifies the first dimension of C as declared
26037 * in the calling (sub) program. LDC must be at least
26038 * max( 1, n ).
26039 * Unchanged on exit.
26040 *
26041 *
26042 * Level 3 Blas routine.
26043 *
26044 * -- Written on 8-February-1989.
26045 * Jack Dongarra, Argonne National Laboratory.
26046 * Iain Duff, AERE Harwell.
26047 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
26048 * Sven Hammarling, Numerical Algorithms Group Ltd.
26049 *
26050 * -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
26051 * Ed Anderson, Cray Research Inc.
26052 *
26053 *
26054 * .. External Functions ..
26055  LOGICAL LSAME
26056  EXTERNAL lsame
26057 * ..
26058 * .. External Subroutines ..
26059  EXTERNAL xerbla
26060 * ..
26061 * .. Intrinsic Functions ..
26062  INTRINSIC dble, dcmplx, dconjg, max
26063 * ..
26064 * .. Local Scalars ..
26065  LOGICAL UPPER
26066  INTEGER I, INFO, J, L, NROWA
26067  DOUBLE PRECISION RTEMP
26068  COMPLEX*16 TEMP
26069 * ..
26070 * .. Parameters ..
26071  DOUBLE PRECISION ONE, ZERO
26072  parameter( one = 1.0d+0, zero = 0.0d+0 )
26073 * ..
26074 * .. Executable Statements ..
26075 *
26076 * Test the input parameters.
26077 *
26078  IF( lsame( trans, 'N' ) ) THEN
26079  nrowa = n
26080  ELSE
26081  nrowa = k
26082  END IF
26083  upper = lsame( uplo, 'U' )
26084 *
26085  info = 0
26086  IF( ( .NOT.upper ) .AND. ( .NOT.lsame( uplo, 'L' ) ) ) THEN
26087  info = 1
26088  ELSE IF( ( .NOT.lsame( trans, 'N' ) ) .AND.
26089  $ ( .NOT.lsame( trans, 'C' ) ) ) THEN
26090  info = 2
26091  ELSE IF( n.LT.0 ) THEN
26092  info = 3
26093  ELSE IF( k.LT.0 ) THEN
26094  info = 4
26095  ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
26096  info = 7
26097  ELSE IF( ldc.LT.max( 1, n ) ) THEN
26098  info = 10
26099  END IF
26100  IF( info.NE.0 ) THEN
26101  CALL xerbla( 'ZHERK ', info )
26102  RETURN
26103  END IF
26104 *
26105 * Quick return if possible.
26106 *
26107  IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
26108  $ ( beta.EQ.one ) ) )RETURN
26109 *
26110 * And when alpha.eq.zero.
26111 *
26112  IF( alpha.EQ.zero ) THEN
26113  IF( upper ) THEN
26114  IF( beta.EQ.zero ) THEN
26115  DO 20 j = 1, n
26116  DO 10 i = 1, j
26117  c( i, j ) = zero
26118  10 CONTINUE
26119  20 CONTINUE
26120  ELSE
26121  DO 40 j = 1, n
26122  DO 30 i = 1, j - 1
26123  c( i, j ) = beta*c( i, j )
26124  30 CONTINUE
26125  c( j, j ) = beta*dble( c( j, j ) )
26126  40 CONTINUE
26127  END IF
26128  ELSE
26129  IF( beta.EQ.zero ) THEN
26130  DO 60 j = 1, n
26131  DO 50 i = j, n
26132  c( i, j ) = zero
26133  50 CONTINUE
26134  60 CONTINUE
26135  ELSE
26136  DO 80 j = 1, n
26137  c( j, j ) = beta*dble( c( j, j ) )
26138  DO 70 i = j + 1, n
26139  c( i, j ) = beta*c( i, j )
26140  70 CONTINUE
26141  80 CONTINUE
26142  END IF
26143  END IF
26144  RETURN
26145  END IF
26146 *
26147 * Start the operations.
26148 *
26149  IF( lsame( trans, 'N' ) ) THEN
26150 *
26151 * Form C := alpha*A*conjg( A' ) + beta*C.
26152 *
26153  IF( upper ) THEN
26154  DO 130 j = 1, n
26155  IF( beta.EQ.zero ) THEN
26156  DO 90 i = 1, j
26157  c( i, j ) = zero
26158  90 CONTINUE
26159  ELSE IF( beta.NE.one ) THEN
26160  DO 100 i = 1, j - 1
26161  c( i, j ) = beta*c( i, j )
26162  100 CONTINUE
26163  c( j, j ) = beta*dble( c( j, j ) )
26164  ELSE
26165  c( j, j ) = dble( c( j, j ) )
26166  END IF
26167  DO 120 l = 1, k
26168  IF( a( j, l ).NE.dcmplx( zero ) ) THEN
26169  temp = alpha*dconjg( a( j, l ) )
26170  DO 110 i = 1, j - 1
26171  c( i, j ) = c( i, j ) + temp*a( i, l )
26172  110 CONTINUE
26173  c( j, j ) = dble( c( j, j ) ) +
26174  $ dble( temp*a( i, l ) )
26175  END IF
26176  120 CONTINUE
26177  130 CONTINUE
26178  ELSE
26179  DO 180 j = 1, n
26180  IF( beta.EQ.zero ) THEN
26181  DO 140 i = j, n
26182  c( i, j ) = zero
26183  140 CONTINUE
26184  ELSE IF( beta.NE.one ) THEN
26185  c( j, j ) = beta*dble( c( j, j ) )
26186  DO 150 i = j + 1, n
26187  c( i, j ) = beta*c( i, j )
26188  150 CONTINUE
26189  ELSE
26190  c( j, j ) = dble( c( j, j ) )
26191  END IF
26192  DO 170 l = 1, k
26193  IF( a( j, l ).NE.dcmplx( zero ) ) THEN
26194  temp = alpha*dconjg( a( j, l ) )
26195  c( j, j ) = dble( c( j, j ) ) +
26196  $ dble( temp*a( j, l ) )
26197  DO 160 i = j + 1, n
26198  c( i, j ) = c( i, j ) + temp*a( i, l )
26199  160 CONTINUE
26200  END IF
26201  170 CONTINUE
26202  180 CONTINUE
26203  END IF
26204  ELSE
26205 *
26206 * Form C := alpha*conjg( A' )*A + beta*C.
26207 *
26208  IF( upper ) THEN
26209  DO 220 j = 1, n
26210  DO 200 i = 1, j - 1
26211  temp = zero
26212  DO 190 l = 1, k
26213  temp = temp + dconjg( a( l, i ) )*a( l, j )
26214  190 CONTINUE
26215  IF( beta.EQ.zero ) THEN
26216  c( i, j ) = alpha*temp
26217  ELSE
26218  c( i, j ) = alpha*temp + beta*c( i, j )
26219  END IF
26220  200 CONTINUE
26221  rtemp = zero
26222  DO 210 l = 1, k
26223  rtemp = rtemp + dconjg( a( l, j ) )*a( l, j )
26224  210 CONTINUE
26225  IF( beta.EQ.zero ) THEN
26226  c( j, j ) = alpha*rtemp
26227  ELSE
26228  c( j, j ) = alpha*rtemp + beta*dble( c( j, j ) )
26229  END IF
26230  220 CONTINUE
26231  ELSE
26232  DO 260 j = 1, n
26233  rtemp = zero
26234  DO 230 l = 1, k
26235  rtemp = rtemp + dconjg( a( l, j ) )*a( l, j )
26236  230 CONTINUE
26237  IF( beta.EQ.zero ) THEN
26238  c( j, j ) = alpha*rtemp
26239  ELSE
26240  c( j, j ) = alpha*rtemp + beta*dble( c( j, j ) )
26241  END IF
26242  DO 250 i = j + 1, n
26243  temp = zero
26244  DO 240 l = 1, k
26245  temp = temp + dconjg( a( l, i ) )*a( l, j )
26246  240 CONTINUE
26247  IF( beta.EQ.zero ) THEN
26248  c( i, j ) = alpha*temp
26249  ELSE
26250  c( i, j ) = alpha*temp + beta*c( i, j )
26251  END IF
26252  250 CONTINUE
26253  260 CONTINUE
26254  END IF
26255  END IF
26256 *
26257  RETURN
26258 *
26259 * End of ZHERK .
26260 *
26261  END
26262  SUBROUTINE zhpmv ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
26263 * .. Scalar Arguments ..
26264  COMPLEX*16 ALPHA, BETA
26265  INTEGER INCX, INCY, N
26266  CHARACTER*1 UPLO
26267 * .. Array Arguments ..
26268  COMPLEX*16 AP( * ), X( * ), Y( * )
26269 * ..
26270 *
26271 * Purpose
26272 * =======
26273 *
26274 * ZHPMV performs the matrix-vector operation
26275 *
26276 * y := alpha*A*x + beta*y,
26277 *
26278 * where alpha and beta are scalars, x and y are n element vectors and
26279 * A is an n by n hermitian matrix, supplied in packed form.
26280 *
26281 * Parameters
26282 * ==========
26283 *
26284 * UPLO - CHARACTER*1.
26285 * On entry, UPLO specifies whether the upper or lower
26286 * triangular part of the matrix A is supplied in the packed
26287 * array AP as follows:
26288 *
26289 * UPLO = 'U' or 'u' The upper triangular part of A is
26290 * supplied in AP.
26291 *
26292 * UPLO = 'L' or 'l' The lower triangular part of A is
26293 * supplied in AP.
26294 *
26295 * Unchanged on exit.
26296 *
26297 * N - INTEGER.
26298 * On entry, N specifies the order of the matrix A.
26299 * N must be at least zero.
26300 * Unchanged on exit.
26301 *
26302 * ALPHA - COMPLEX*16 .
26303 * On entry, ALPHA specifies the scalar alpha.
26304 * Unchanged on exit.
26305 *
26306 * AP - COMPLEX*16 array of DIMENSION at least
26307 * ( ( n*( n + 1 ) )/2 ).
26308 * Before entry with UPLO = 'U' or 'u', the array AP must
26309 * contain the upper triangular part of the hermitian matrix
26310 * packed sequentially, column by column, so that AP( 1 )
26311 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
26312 * and a( 2, 2 ) respectively, and so on.
26313 * Before entry with UPLO = 'L' or 'l', the array AP must
26314 * contain the lower triangular part of the hermitian matrix
26315 * packed sequentially, column by column, so that AP( 1 )
26316 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
26317 * and a( 3, 1 ) respectively, and so on.
26318 * Note that the imaginary parts of the diagonal elements need
26319 * not be set and are assumed to be zero.
26320 * Unchanged on exit.
26321 *
26322 * X - COMPLEX*16 array of dimension at least
26323 * ( 1 + ( n - 1 )*abs( INCX ) ).
26324 * Before entry, the incremented array X must contain the n
26325 * element vector x.
26326 * Unchanged on exit.
26327 *
26328 * INCX - INTEGER.
26329 * On entry, INCX specifies the increment for the elements of
26330 * X. INCX must not be zero.
26331 * Unchanged on exit.
26332 *
26333 * BETA - COMPLEX*16 .
26334 * On entry, BETA specifies the scalar beta. When BETA is
26335 * supplied as zero then Y need not be set on input.
26336 * Unchanged on exit.
26337 *
26338 * Y - COMPLEX*16 array of dimension at least
26339 * ( 1 + ( n - 1 )*abs( INCY ) ).
26340 * Before entry, the incremented array Y must contain the n
26341 * element vector y. On exit, Y is overwritten by the updated
26342 * vector y.
26343 *
26344 * INCY - INTEGER.
26345 * On entry, INCY specifies the increment for the elements of
26346 * Y. INCY must not be zero.
26347 * Unchanged on exit.
26348 *
26349 *
26350 * Level 2 Blas routine.
26351 *
26352 * -- Written on 22-October-1986.
26353 * Jack Dongarra, Argonne National Lab.
26354 * Jeremy Du Croz, Nag Central Office.
26355 * Sven Hammarling, Nag Central Office.
26356 * Richard Hanson, Sandia National Labs.
26357 *
26358 *
26359 * .. Parameters ..
26360  COMPLEX*16 ONE
26361  parameter( one = ( 1.0d+0, 0.0d+0 ) )
26362  COMPLEX*16 ZERO
26363  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
26364 * .. Local Scalars ..
26365  COMPLEX*16 TEMP1, TEMP2
26366  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
26367 * .. External Functions ..
26368  LOGICAL LSAME
26369  EXTERNAL lsame
26370 * .. External Subroutines ..
26371  EXTERNAL xerbla
26372 * .. Intrinsic Functions ..
26373  INTRINSIC dconjg, dble
26374 * ..
26375 * .. Executable Statements ..
26376 *
26377 * Test the input parameters.
26378 *
26379  info = 0
26380  IF ( .NOT.lsame( uplo, 'U' ).AND.
26381  $ .NOT.lsame( uplo, 'L' ) )THEN
26382  info = 1
26383  ELSE IF( n.LT.0 )THEN
26384  info = 2
26385  ELSE IF( incx.EQ.0 )THEN
26386  info = 6
26387  ELSE IF( incy.EQ.0 )THEN
26388  info = 9
26389  END IF
26390  IF( info.NE.0 )THEN
26391  CALL xerbla( 'ZHPMV ', info )
26392  RETURN
26393  END IF
26394 *
26395 * Quick return if possible.
26396 *
26397  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
26398  $ RETURN
26399 *
26400 * Set up the start points in X and Y.
26401 *
26402  IF( incx.GT.0 )THEN
26403  kx = 1
26404  ELSE
26405  kx = 1 - ( n - 1 )*incx
26406  END IF
26407  IF( incy.GT.0 )THEN
26408  ky = 1
26409  ELSE
26410  ky = 1 - ( n - 1 )*incy
26411  END IF
26412 *
26413 * Start the operations. In this version the elements of the array AP
26414 * are accessed sequentially with one pass through AP.
26415 *
26416 * First form y := beta*y.
26417 *
26418  IF( beta.NE.one )THEN
26419  IF( incy.EQ.1 )THEN
26420  IF( beta.EQ.zero )THEN
26421  DO 10, i = 1, n
26422  y( i ) = zero
26423  10 CONTINUE
26424  ELSE
26425  DO 20, i = 1, n
26426  y( i ) = beta*y( i )
26427  20 CONTINUE
26428  END IF
26429  ELSE
26430  iy = ky
26431  IF( beta.EQ.zero )THEN
26432  DO 30, i = 1, n
26433  y( iy ) = zero
26434  iy = iy + incy
26435  30 CONTINUE
26436  ELSE
26437  DO 40, i = 1, n
26438  y( iy ) = beta*y( iy )
26439  iy = iy + incy
26440  40 CONTINUE
26441  END IF
26442  END IF
26443  END IF
26444  IF( alpha.EQ.zero )
26445  $ RETURN
26446  kk = 1
26447  IF( lsame( uplo, 'U' ) )THEN
26448 *
26449 * Form y when AP contains the upper triangle.
26450 *
26451  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
26452  DO 60, j = 1, n
26453  temp1 = alpha*x( j )
26454  temp2 = zero
26455  k = kk
26456  DO 50, i = 1, j - 1
26457  y( i ) = y( i ) + temp1*ap( k )
26458  temp2 = temp2 + dconjg( ap( k ) )*x( i )
26459  k = k + 1
26460  50 CONTINUE
26461  y( j ) = y( j ) + temp1*dble( ap( kk + j - 1 ) )
26462  $ + alpha*temp2
26463  kk = kk + j
26464  60 CONTINUE
26465  ELSE
26466  jx = kx
26467  jy = ky
26468  DO 80, j = 1, n
26469  temp1 = alpha*x( jx )
26470  temp2 = zero
26471  ix = kx
26472  iy = ky
26473  DO 70, k = kk, kk + j - 2
26474  y( iy ) = y( iy ) + temp1*ap( k )
26475  temp2 = temp2 + dconjg( ap( k ) )*x( ix )
26476  ix = ix + incx
26477  iy = iy + incy
26478  70 CONTINUE
26479  y( jy ) = y( jy ) + temp1*dble( ap( kk + j - 1 ) )
26480  $ + alpha*temp2
26481  jx = jx + incx
26482  jy = jy + incy
26483  kk = kk + j
26484  80 CONTINUE
26485  END IF
26486  ELSE
26487 *
26488 * Form y when AP contains the lower triangle.
26489 *
26490  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
26491  DO 100, j = 1, n
26492  temp1 = alpha*x( j )
26493  temp2 = zero
26494  y( j ) = y( j ) + temp1*dble( ap( kk ) )
26495  k = kk + 1
26496  DO 90, i = j + 1, n
26497  y( i ) = y( i ) + temp1*ap( k )
26498  temp2 = temp2 + dconjg( ap( k ) )*x( i )
26499  k = k + 1
26500  90 CONTINUE
26501  y( j ) = y( j ) + alpha*temp2
26502  kk = kk + ( n - j + 1 )
26503  100 CONTINUE
26504  ELSE
26505  jx = kx
26506  jy = ky
26507  DO 120, j = 1, n
26508  temp1 = alpha*x( jx )
26509  temp2 = zero
26510  y( jy ) = y( jy ) + temp1*dble( ap( kk ) )
26511  ix = jx
26512  iy = jy
26513  DO 110, k = kk + 1, kk + n - j
26514  ix = ix + incx
26515  iy = iy + incy
26516  y( iy ) = y( iy ) + temp1*ap( k )
26517  temp2 = temp2 + dconjg( ap( k ) )*x( ix )
26518  110 CONTINUE
26519  y( jy ) = y( jy ) + alpha*temp2
26520  jx = jx + incx
26521  jy = jy + incy
26522  kk = kk + ( n - j + 1 )
26523  120 CONTINUE
26524  END IF
26525  END IF
26526 *
26527  RETURN
26528 *
26529 * End of ZHPMV .
26530 *
26531  END
26532  SUBROUTINE zhpr2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
26533 * .. Scalar Arguments ..
26534  COMPLEX*16 ALPHA
26535  INTEGER INCX, INCY, N
26536  CHARACTER*1 UPLO
26537 * .. Array Arguments ..
26538  COMPLEX*16 AP( * ), X( * ), Y( * )
26539 * ..
26540 *
26541 * Purpose
26542 * =======
26543 *
26544 * ZHPR2 performs the hermitian rank 2 operation
26545 *
26546 * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
26547 *
26548 * where alpha is a scalar, x and y are n element vectors and A is an
26549 * n by n hermitian matrix, supplied in packed form.
26550 *
26551 * Parameters
26552 * ==========
26553 *
26554 * UPLO - CHARACTER*1.
26555 * On entry, UPLO specifies whether the upper or lower
26556 * triangular part of the matrix A is supplied in the packed
26557 * array AP as follows:
26558 *
26559 * UPLO = 'U' or 'u' The upper triangular part of A is
26560 * supplied in AP.
26561 *
26562 * UPLO = 'L' or 'l' The lower triangular part of A is
26563 * supplied in AP.
26564 *
26565 * Unchanged on exit.
26566 *
26567 * N - INTEGER.
26568 * On entry, N specifies the order of the matrix A.
26569 * N must be at least zero.
26570 * Unchanged on exit.
26571 *
26572 * ALPHA - COMPLEX*16 .
26573 * On entry, ALPHA specifies the scalar alpha.
26574 * Unchanged on exit.
26575 *
26576 * X - COMPLEX*16 array of dimension at least
26577 * ( 1 + ( n - 1 )*abs( INCX ) ).
26578 * Before entry, the incremented array X must contain the n
26579 * element vector x.
26580 * Unchanged on exit.
26581 *
26582 * INCX - INTEGER.
26583 * On entry, INCX specifies the increment for the elements of
26584 * X. INCX must not be zero.
26585 * Unchanged on exit.
26586 *
26587 * Y - COMPLEX*16 array of dimension at least
26588 * ( 1 + ( n - 1 )*abs( INCY ) ).
26589 * Before entry, the incremented array Y must contain the n
26590 * element vector y.
26591 * Unchanged on exit.
26592 *
26593 * INCY - INTEGER.
26594 * On entry, INCY specifies the increment for the elements of
26595 * Y. INCY must not be zero.
26596 * Unchanged on exit.
26597 *
26598 * AP - COMPLEX*16 array of DIMENSION at least
26599 * ( ( n*( n + 1 ) )/2 ).
26600 * Before entry with UPLO = 'U' or 'u', the array AP must
26601 * contain the upper triangular part of the hermitian matrix
26602 * packed sequentially, column by column, so that AP( 1 )
26603 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
26604 * and a( 2, 2 ) respectively, and so on. On exit, the array
26605 * AP is overwritten by the upper triangular part of the
26606 * updated matrix.
26607 * Before entry with UPLO = 'L' or 'l', the array AP must
26608 * contain the lower triangular part of the hermitian matrix
26609 * packed sequentially, column by column, so that AP( 1 )
26610 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
26611 * and a( 3, 1 ) respectively, and so on. On exit, the array
26612 * AP is overwritten by the lower triangular part of the
26613 * updated matrix.
26614 * Note that the imaginary parts of the diagonal elements need
26615 * not be set, they are assumed to be zero, and on exit they
26616 * are set to zero.
26617 *
26618 *
26619 * Level 2 Blas routine.
26620 *
26621 * -- Written on 22-October-1986.
26622 * Jack Dongarra, Argonne National Lab.
26623 * Jeremy Du Croz, Nag Central Office.
26624 * Sven Hammarling, Nag Central Office.
26625 * Richard Hanson, Sandia National Labs.
26626 *
26627 *
26628 * .. Parameters ..
26629  COMPLEX*16 ZERO
26630  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
26631 * .. Local Scalars ..
26632  COMPLEX*16 TEMP1, TEMP2
26633  INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
26634 * .. External Functions ..
26635  LOGICAL LSAME
26636  EXTERNAL lsame
26637 * .. External Subroutines ..
26638  EXTERNAL xerbla
26639 * .. Intrinsic Functions ..
26640  INTRINSIC dconjg, dble
26641 * ..
26642 * .. Executable Statements ..
26643 *
26644 * Test the input parameters.
26645 *
26646  info = 0
26647  IF ( .NOT.lsame( uplo, 'U' ).AND.
26648  $ .NOT.lsame( uplo, 'L' ) )THEN
26649  info = 1
26650  ELSE IF( n.LT.0 )THEN
26651  info = 2
26652  ELSE IF( incx.EQ.0 )THEN
26653  info = 5
26654  ELSE IF( incy.EQ.0 )THEN
26655  info = 7
26656  END IF
26657  IF( info.NE.0 )THEN
26658  CALL xerbla( 'ZHPR2 ', info )
26659  RETURN
26660  END IF
26661 *
26662 * Quick return if possible.
26663 *
26664  IF( ( n.EQ.0 ).OR.( alpha.EQ.zero ) )
26665  $ RETURN
26666 *
26667 * Set up the start points in X and Y if the increments are not both
26668 * unity.
26669 *
26670  IF( ( incx.NE.1 ).OR.( incy.NE.1 ) )THEN
26671  IF( incx.GT.0 )THEN
26672  kx = 1
26673  ELSE
26674  kx = 1 - ( n - 1 )*incx
26675  END IF
26676  IF( incy.GT.0 )THEN
26677  ky = 1
26678  ELSE
26679  ky = 1 - ( n - 1 )*incy
26680  END IF
26681  jx = kx
26682  jy = ky
26683  END IF
26684 *
26685 * Start the operations. In this version the elements of the array AP
26686 * are accessed sequentially with one pass through AP.
26687 *
26688  kk = 1
26689  IF( lsame( uplo, 'U' ) )THEN
26690 *
26691 * Form A when upper triangle is stored in AP.
26692 *
26693  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
26694  DO 20, j = 1, n
26695  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
26696  temp1 = alpha*dconjg( y( j ) )
26697  temp2 = dconjg( alpha*x( j ) )
26698  k = kk
26699  DO 10, i = 1, j - 1
26700  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
26701  k = k + 1
26702  10 CONTINUE
26703  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) ) +
26704  $ dble( x( j )*temp1 + y( j )*temp2 )
26705  ELSE
26706  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26707  END IF
26708  kk = kk + j
26709  20 CONTINUE
26710  ELSE
26711  DO 40, j = 1, n
26712  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
26713  temp1 = alpha*dconjg( y( jy ) )
26714  temp2 = dconjg( alpha*x( jx ) )
26715  ix = kx
26716  iy = ky
26717  DO 30, k = kk, kk + j - 2
26718  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
26719  ix = ix + incx
26720  iy = iy + incy
26721  30 CONTINUE
26722  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) ) +
26723  $ dble( x( jx )*temp1 +
26724  $ y( jy )*temp2 )
26725  ELSE
26726  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26727  END IF
26728  jx = jx + incx
26729  jy = jy + incy
26730  kk = kk + j
26731  40 CONTINUE
26732  END IF
26733  ELSE
26734 *
26735 * Form A when lower triangle is stored in AP.
26736 *
26737  IF( ( incx.EQ.1 ).AND.( incy.EQ.1 ) )THEN
26738  DO 60, j = 1, n
26739  IF( ( x( j ).NE.zero ).OR.( y( j ).NE.zero ) )THEN
26740  temp1 = alpha*dconjg( y( j ) )
26741  temp2 = dconjg( alpha*x( j ) )
26742  ap( kk ) = dble( ap( kk ) ) +
26743  $ dble( x( j )*temp1 + y( j )*temp2 )
26744  k = kk + 1
26745  DO 50, i = j + 1, n
26746  ap( k ) = ap( k ) + x( i )*temp1 + y( i )*temp2
26747  k = k + 1
26748  50 CONTINUE
26749  ELSE
26750  ap( kk ) = dble( ap( kk ) )
26751  END IF
26752  kk = kk + n - j + 1
26753  60 CONTINUE
26754  ELSE
26755  DO 80, j = 1, n
26756  IF( ( x( jx ).NE.zero ).OR.( y( jy ).NE.zero ) )THEN
26757  temp1 = alpha*dconjg( y( jy ) )
26758  temp2 = dconjg( alpha*x( jx ) )
26759  ap( kk ) = dble( ap( kk ) ) +
26760  $ dble( x( jx )*temp1 + y( jy )*temp2 )
26761  ix = jx
26762  iy = jy
26763  DO 70, k = kk + 1, kk + n - j
26764  ix = ix + incx
26765  iy = iy + incy
26766  ap( k ) = ap( k ) + x( ix )*temp1 + y( iy )*temp2
26767  70 CONTINUE
26768  ELSE
26769  ap( kk ) = dble( ap( kk ) )
26770  END IF
26771  jx = jx + incx
26772  jy = jy + incy
26773  kk = kk + n - j + 1
26774  80 CONTINUE
26775  END IF
26776  END IF
26777 *
26778  RETURN
26779 *
26780 * End of ZHPR2 .
26781 *
26782  END
26783  SUBROUTINE zhpr ( UPLO, N, ALPHA, X, INCX, AP )
26784 * .. Scalar Arguments ..
26785  DOUBLE PRECISION ALPHA
26786  INTEGER INCX, N
26787  CHARACTER*1 UPLO
26788 * .. Array Arguments ..
26789  COMPLEX*16 AP( * ), X( * )
26790 * ..
26791 *
26792 * Purpose
26793 * =======
26794 *
26795 * ZHPR performs the hermitian rank 1 operation
26796 *
26797 * A := alpha*x*conjg( x' ) + A,
26798 *
26799 * where alpha is a real scalar, x is an n element vector and A is an
26800 * n by n hermitian matrix, supplied in packed form.
26801 *
26802 * Parameters
26803 * ==========
26804 *
26805 * UPLO - CHARACTER*1.
26806 * On entry, UPLO specifies whether the upper or lower
26807 * triangular part of the matrix A is supplied in the packed
26808 * array AP as follows:
26809 *
26810 * UPLO = 'U' or 'u' The upper triangular part of A is
26811 * supplied in AP.
26812 *
26813 * UPLO = 'L' or 'l' The lower triangular part of A is
26814 * supplied in AP.
26815 *
26816 * Unchanged on exit.
26817 *
26818 * N - INTEGER.
26819 * On entry, N specifies the order of the matrix A.
26820 * N must be at least zero.
26821 * Unchanged on exit.
26822 *
26823 * ALPHA - DOUBLE PRECISION.
26824 * On entry, ALPHA specifies the scalar alpha.
26825 * Unchanged on exit.
26826 *
26827 * X - COMPLEX*16 array of dimension at least
26828 * ( 1 + ( n - 1 )*abs( INCX ) ).
26829 * Before entry, the incremented array X must contain the n
26830 * element vector x.
26831 * Unchanged on exit.
26832 *
26833 * INCX - INTEGER.
26834 * On entry, INCX specifies the increment for the elements of
26835 * X. INCX must not be zero.
26836 * Unchanged on exit.
26837 *
26838 * AP - COMPLEX*16 array of DIMENSION at least
26839 * ( ( n*( n + 1 ) )/2 ).
26840 * Before entry with UPLO = 'U' or 'u', the array AP must
26841 * contain the upper triangular part of the hermitian matrix
26842 * packed sequentially, column by column, so that AP( 1 )
26843 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
26844 * and a( 2, 2 ) respectively, and so on. On exit, the array
26845 * AP is overwritten by the upper triangular part of the
26846 * updated matrix.
26847 * Before entry with UPLO = 'L' or 'l', the array AP must
26848 * contain the lower triangular part of the hermitian matrix
26849 * packed sequentially, column by column, so that AP( 1 )
26850 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
26851 * and a( 3, 1 ) respectively, and so on. On exit, the array
26852 * AP is overwritten by the lower triangular part of the
26853 * updated matrix.
26854 * Note that the imaginary parts of the diagonal elements need
26855 * not be set, they are assumed to be zero, and on exit they
26856 * are set to zero.
26857 *
26858 *
26859 * Level 2 Blas routine.
26860 *
26861 * -- Written on 22-October-1986.
26862 * Jack Dongarra, Argonne National Lab.
26863 * Jeremy Du Croz, Nag Central Office.
26864 * Sven Hammarling, Nag Central Office.
26865 * Richard Hanson, Sandia National Labs.
26866 *
26867 *
26868 * .. Parameters ..
26869  COMPLEX*16 ZERO
26870  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
26871 * .. Local Scalars ..
26872  COMPLEX*16 TEMP
26873  INTEGER I, INFO, IX, J, JX, K, KK, KX
26874 * .. External Functions ..
26875  LOGICAL LSAME
26876  EXTERNAL lsame
26877 * .. External Subroutines ..
26878  EXTERNAL xerbla
26879 * .. Intrinsic Functions ..
26880  INTRINSIC dconjg, dble
26881 * ..
26882 * .. Executable Statements ..
26883 *
26884 * Test the input parameters.
26885 *
26886  info = 0
26887  IF ( .NOT.lsame( uplo, 'U' ).AND.
26888  $ .NOT.lsame( uplo, 'L' ) )THEN
26889  info = 1
26890  ELSE IF( n.LT.0 )THEN
26891  info = 2
26892  ELSE IF( incx.EQ.0 )THEN
26893  info = 5
26894  END IF
26895  IF( info.NE.0 )THEN
26896  CALL xerbla( 'ZHPR ', info )
26897  RETURN
26898  END IF
26899 *
26900 * Quick return if possible.
26901 *
26902  IF( ( n.EQ.0 ).OR.( alpha.EQ.dble( zero ) ) )
26903  $ RETURN
26904 *
26905 * Set the start point in X if the increment is not unity.
26906 *
26907  IF( incx.LE.0 )THEN
26908  kx = 1 - ( n - 1 )*incx
26909  ELSE IF( incx.NE.1 )THEN
26910  kx = 1
26911  END IF
26912 *
26913 * Start the operations. In this version the elements of the array AP
26914 * are accessed sequentially with one pass through AP.
26915 *
26916  kk = 1
26917  IF( lsame( uplo, 'U' ) )THEN
26918 *
26919 * Form A when upper triangle is stored in AP.
26920 *
26921  IF( incx.EQ.1 )THEN
26922  DO 20, j = 1, n
26923  IF( x( j ).NE.zero )THEN
26924  temp = alpha*dconjg( x( j ) )
26925  k = kk
26926  DO 10, i = 1, j - 1
26927  ap( k ) = ap( k ) + x( i )*temp
26928  k = k + 1
26929  10 CONTINUE
26930  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26931  $ + dble( x( j )*temp )
26932  ELSE
26933  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26934  END IF
26935  kk = kk + j
26936  20 CONTINUE
26937  ELSE
26938  jx = kx
26939  DO 40, j = 1, n
26940  IF( x( jx ).NE.zero )THEN
26941  temp = alpha*dconjg( x( jx ) )
26942  ix = kx
26943  DO 30, k = kk, kk + j - 2
26944  ap( k ) = ap( k ) + x( ix )*temp
26945  ix = ix + incx
26946  30 CONTINUE
26947  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26948  $ + dble( x( jx )*temp )
26949  ELSE
26950  ap( kk + j - 1 ) = dble( ap( kk + j - 1 ) )
26951  END IF
26952  jx = jx + incx
26953  kk = kk + j
26954  40 CONTINUE
26955  END IF
26956  ELSE
26957 *
26958 * Form A when lower triangle is stored in AP.
26959 *
26960  IF( incx.EQ.1 )THEN
26961  DO 60, j = 1, n
26962  IF( x( j ).NE.zero )THEN
26963  temp = alpha*dconjg( x( j ) )
26964  ap( kk ) = dble( ap( kk ) ) + dble( temp*x( j ) )
26965  k = kk + 1
26966  DO 50, i = j + 1, n
26967  ap( k ) = ap( k ) + x( i )*temp
26968  k = k + 1
26969  50 CONTINUE
26970  ELSE
26971  ap( kk ) = dble( ap( kk ) )
26972  END IF
26973  kk = kk + n - j + 1
26974  60 CONTINUE
26975  ELSE
26976  jx = kx
26977  DO 80, j = 1, n
26978  IF( x( jx ).NE.zero )THEN
26979  temp = alpha*dconjg( x( jx ) )
26980  ap( kk ) = dble( ap( kk ) ) + dble( temp*x( jx ) )
26981  ix = jx
26982  DO 70, k = kk + 1, kk + n - j
26983  ix = ix + incx
26984  ap( k ) = ap( k ) + x( ix )*temp
26985  70 CONTINUE
26986  ELSE
26987  ap( kk ) = dble( ap( kk ) )
26988  END IF
26989  jx = jx + incx
26990  kk = kk + n - j + 1
26991  80 CONTINUE
26992  END IF
26993  END IF
26994 *
26995  RETURN
26996 *
26997 * End of ZHPR .
26998 *
26999  END
27000  subroutine zrotg(ca,cb,c,s)
27001  double complex ca,cb,s
27002  double precision c
27003  double precision norm,scale
27004  double complex alpha
27005  if (cdabs(ca) .ne. 0.0d0) go to 10
27006  c = 0.0d0
27007  s = (1.0d0,0.0d0)
27008  ca = cb
27009  go to 20
27010  10 continue
27011  scale = cdabs(ca) + cdabs(cb)
27012  norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +
27013  * (cdabs(cb/dcmplx(scale,0.0d0)))**2)
27014  alpha = ca /cdabs(ca)
27015  c = cdabs(ca) / norm
27016  s = alpha * dconjg(cb) / norm
27017  ca = alpha * norm
27018  20 continue
27019  return
27020  end
27021  subroutine zscal(n,za,zx,incx)
27022 c
27023 c scales a vector by a constant.
27024 c jack dongarra, 3/11/78.
27025 c modified 3/93 to return if incx .le. 0.
27026 c modified 12/3/93, array(1) declarations changed to array(*)
27027 c
27028  double complex za,zx(*)
27029  integer i,incx,ix,n
27030 c
27031  if( n.le.0 .or. incx.le.0 )return
27032  if(incx.eq.1)go to 20
27033 c
27034 c code for increment not equal to 1
27035 c
27036  ix = 1
27037  do 10 i = 1,n
27038  zx(ix) = za*zx(ix)
27039  ix = ix + incx
27040  10 continue
27041  return
27042 c
27043 c code for increment equal to 1
27044 c
27045  20 do 30 i = 1,n
27046  zx(i) = za*zx(i)
27047  30 continue
27048  return
27049  end
27050  subroutine zswap (n,zx,incx,zy,incy)
27051 c
27052 c interchanges two vectors.
27053 c jack dongarra, 3/11/78.
27054 c modified 12/3/93, array(1) declarations changed to array(*)
27055 c
27056  double complex zx(*),zy(*),ztemp
27057  integer i,incx,incy,ix,iy,n
27058 c
27059  if(n.le.0)return
27060  if(incx.eq.1.and.incy.eq.1)go to 20
27061 c
27062 c code for unequal increments or equal increments not equal
27063 c to 1
27064 c
27065  ix = 1
27066  iy = 1
27067  if(incx.lt.0)ix = (-n+1)*incx + 1
27068  if(incy.lt.0)iy = (-n+1)*incy + 1
27069  do 10 i = 1,n
27070  ztemp = zx(ix)
27071  zx(ix) = zy(iy)
27072  zy(iy) = ztemp
27073  ix = ix + incx
27074  iy = iy + incy
27075  10 continue
27076  return
27077 c
27078 c code for both increments equal to 1
27079  20 do 30 i = 1,n
27080  ztemp = zx(i)
27081  zx(i) = zy(i)
27082  zy(i) = ztemp
27083  30 continue
27084  return
27085  end
27086  SUBROUTINE zsymm ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
27087  $ beta, c, ldc )
27088 * .. Scalar Arguments ..
27089  CHARACTER*1 SIDE, UPLO
27090  INTEGER M, N, LDA, LDB, LDC
27091  COMPLEX*16 ALPHA, BETA
27092 * .. Array Arguments ..
27093  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
27094 * ..
27095 *
27096 * Purpose
27097 * =======
27098 *
27099 * ZSYMM performs one of the matrix-matrix operations
27100 *
27101 * C := alpha*A*B + beta*C,
27102 *
27103 * or
27104 *
27105 * C := alpha*B*A + beta*C,
27106 *
27107 * where alpha and beta are scalars, A is a symmetric matrix and B and
27108 * C are m by n matrices.
27109 *
27110 * Parameters
27111 * ==========
27112 *
27113 * SIDE - CHARACTER*1.
27114 * On entry, SIDE specifies whether the symmetric matrix A
27115 * appears on the left or right in the operation as follows:
27116 *
27117 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
27118 *
27119 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
27120 *
27121 * Unchanged on exit.
27122 *
27123 * UPLO - CHARACTER*1.
27124 * On entry, UPLO specifies whether the upper or lower
27125 * triangular part of the symmetric matrix A is to be
27126 * referenced as follows:
27127 *
27128 * UPLO = 'U' or 'u' Only the upper triangular part of the
27129 * symmetric matrix is to be referenced.
27130 *
27131 * UPLO = 'L' or 'l' Only the lower triangular part of the
27132 * symmetric matrix is to be referenced.
27133 *
27134 * Unchanged on exit.
27135 *
27136 * M - INTEGER.
27137 * On entry, M specifies the number of rows of the matrix C.
27138 * M must be at least zero.
27139 * Unchanged on exit.
27140 *
27141 * N - INTEGER.
27142 * On entry, N specifies the number of columns of the matrix C.
27143 * N must be at least zero.
27144 * Unchanged on exit.
27145 *
27146 * ALPHA - COMPLEX*16 .
27147 * On entry, ALPHA specifies the scalar alpha.
27148 * Unchanged on exit.
27149 *
27150 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
27151 * m when SIDE = 'L' or 'l' and is n otherwise.
27152 * Before entry with SIDE = 'L' or 'l', the m by m part of
27153 * the array A must contain the symmetric matrix, such that
27154 * when UPLO = 'U' or 'u', the leading m by m upper triangular
27155 * part of the array A must contain the upper triangular part
27156 * of the symmetric matrix and the strictly lower triangular
27157 * part of A is not referenced, and when UPLO = 'L' or 'l',
27158 * the leading m by m lower triangular part of the array A
27159 * must contain the lower triangular part of the symmetric
27160 * matrix and the strictly upper triangular part of A is not
27161 * referenced.
27162 * Before entry with SIDE = 'R' or 'r', the n by n part of
27163 * the array A must contain the symmetric matrix, such that
27164 * when UPLO = 'U' or 'u', the leading n by n upper triangular
27165 * part of the array A must contain the upper triangular part
27166 * of the symmetric matrix and the strictly lower triangular
27167 * part of A is not referenced, and when UPLO = 'L' or 'l',
27168 * the leading n by n lower triangular part of the array A
27169 * must contain the lower triangular part of the symmetric
27170 * matrix and the strictly upper triangular part of A is not
27171 * referenced.
27172 * Unchanged on exit.
27173 *
27174 * LDA - INTEGER.
27175 * On entry, LDA specifies the first dimension of A as declared
27176 * in the calling (sub) program. When SIDE = 'L' or 'l' then
27177 * LDA must be at least max( 1, m ), otherwise LDA must be at
27178 * least max( 1, n ).
27179 * Unchanged on exit.
27180 *
27181 * B - COMPLEX*16 array of DIMENSION ( LDB, n ).
27182 * Before entry, the leading m by n part of the array B must
27183 * contain the matrix B.
27184 * Unchanged on exit.
27185 *
27186 * LDB - INTEGER.
27187 * On entry, LDB specifies the first dimension of B as declared
27188 * in the calling (sub) program. LDB must be at least
27189 * max( 1, m ).
27190 * Unchanged on exit.
27191 *
27192 * BETA - COMPLEX*16 .
27193 * On entry, BETA specifies the scalar beta. When BETA is
27194 * supplied as zero then C need not be set on input.
27195 * Unchanged on exit.
27196 *
27197 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
27198 * Before entry, the leading m by n part of the array C must
27199 * contain the matrix C, except when beta is zero, in which
27200 * case C need not be set on entry.
27201 * On exit, the array C is overwritten by the m by n updated
27202 * matrix.
27203 *
27204 * LDC - INTEGER.
27205 * On entry, LDC specifies the first dimension of C as declared
27206 * in the calling (sub) program. LDC must be at least
27207 * max( 1, m ).
27208 * Unchanged on exit.
27209 *
27210 *
27211 * Level 3 Blas routine.
27212 *
27213 * -- Written on 8-February-1989.
27214 * Jack Dongarra, Argonne National Laboratory.
27215 * Iain Duff, AERE Harwell.
27216 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
27217 * Sven Hammarling, Numerical Algorithms Group Ltd.
27218 *
27219 *
27220 * .. External Functions ..
27221  LOGICAL LSAME
27222  EXTERNAL lsame
27223 * .. External Subroutines ..
27224  EXTERNAL xerbla
27225 * .. Intrinsic Functions ..
27226  INTRINSIC max
27227 * .. Local Scalars ..
27228  LOGICAL UPPER
27229  INTEGER I, INFO, J, K, NROWA
27230  COMPLEX*16 TEMP1, TEMP2
27231 * .. Parameters ..
27232  COMPLEX*16 ONE
27233  parameter( one = ( 1.0d+0, 0.0d+0 ) )
27234  COMPLEX*16 ZERO
27235  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
27236 * ..
27237 * .. Executable Statements ..
27238 *
27239 * Set NROWA as the number of rows of A.
27240 *
27241  IF( lsame( side, 'L' ) )THEN
27242  nrowa = m
27243  ELSE
27244  nrowa = n
27245  END IF
27246  upper = lsame( uplo, 'U' )
27247 *
27248 * Test the input parameters.
27249 *
27250  info = 0
27251  IF( ( .NOT.lsame( side, 'L' ) ).AND.
27252  $ ( .NOT.lsame( side, 'R' ) ) )THEN
27253  info = 1
27254  ELSE IF( ( .NOT.upper ).AND.
27255  $ ( .NOT.lsame( uplo, 'L' ) ) )THEN
27256  info = 2
27257  ELSE IF( m .LT.0 )THEN
27258  info = 3
27259  ELSE IF( n .LT.0 )THEN
27260  info = 4
27261  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
27262  info = 7
27263  ELSE IF( ldb.LT.max( 1, m ) )THEN
27264  info = 9
27265  ELSE IF( ldc.LT.max( 1, m ) )THEN
27266  info = 12
27267  END IF
27268  IF( info.NE.0 )THEN
27269  CALL xerbla( 'ZSYMM ', info )
27270  RETURN
27271  END IF
27272 *
27273 * Quick return if possible.
27274 *
27275  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
27276  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
27277  $ RETURN
27278 *
27279 * And when alpha.eq.zero.
27280 *
27281  IF( alpha.EQ.zero )THEN
27282  IF( beta.EQ.zero )THEN
27283  DO 20, j = 1, n
27284  DO 10, i = 1, m
27285  c( i, j ) = zero
27286  10 CONTINUE
27287  20 CONTINUE
27288  ELSE
27289  DO 40, j = 1, n
27290  DO 30, i = 1, m
27291  c( i, j ) = beta*c( i, j )
27292  30 CONTINUE
27293  40 CONTINUE
27294  END IF
27295  RETURN
27296  END IF
27297 *
27298 * Start the operations.
27299 *
27300  IF( lsame( side, 'L' ) )THEN
27301 *
27302 * Form C := alpha*A*B + beta*C.
27303 *
27304  IF( upper )THEN
27305  DO 70, j = 1, n
27306  DO 60, i = 1, m
27307  temp1 = alpha*b( i, j )
27308  temp2 = zero
27309  DO 50, k = 1, i - 1
27310  c( k, j ) = c( k, j ) + temp1 *a( k, i )
27311  temp2 = temp2 + b( k, j )*a( k, i )
27312  50 CONTINUE
27313  IF( beta.EQ.zero )THEN
27314  c( i, j ) = temp1*a( i, i ) + alpha*temp2
27315  ELSE
27316  c( i, j ) = beta *c( i, j ) +
27317  $ temp1*a( i, i ) + alpha*temp2
27318  END IF
27319  60 CONTINUE
27320  70 CONTINUE
27321  ELSE
27322  DO 100, j = 1, n
27323  DO 90, i = m, 1, -1
27324  temp1 = alpha*b( i, j )
27325  temp2 = zero
27326  DO 80, k = i + 1, m
27327  c( k, j ) = c( k, j ) + temp1 *a( k, i )
27328  temp2 = temp2 + b( k, j )*a( k, i )
27329  80 CONTINUE
27330  IF( beta.EQ.zero )THEN
27331  c( i, j ) = temp1*a( i, i ) + alpha*temp2
27332  ELSE
27333  c( i, j ) = beta *c( i, j ) +
27334  $ temp1*a( i, i ) + alpha*temp2
27335  END IF
27336  90 CONTINUE
27337  100 CONTINUE
27338  END IF
27339  ELSE
27340 *
27341 * Form C := alpha*B*A + beta*C.
27342 *
27343  DO 170, j = 1, n
27344  temp1 = alpha*a( j, j )
27345  IF( beta.EQ.zero )THEN
27346  DO 110, i = 1, m
27347  c( i, j ) = temp1*b( i, j )
27348  110 CONTINUE
27349  ELSE
27350  DO 120, i = 1, m
27351  c( i, j ) = beta*c( i, j ) + temp1*b( i, j )
27352  120 CONTINUE
27353  END IF
27354  DO 140, k = 1, j - 1
27355  IF( upper )THEN
27356  temp1 = alpha*a( k, j )
27357  ELSE
27358  temp1 = alpha*a( j, k )
27359  END IF
27360  DO 130, i = 1, m
27361  c( i, j ) = c( i, j ) + temp1*b( i, k )
27362  130 CONTINUE
27363  140 CONTINUE
27364  DO 160, k = j + 1, n
27365  IF( upper )THEN
27366  temp1 = alpha*a( j, k )
27367  ELSE
27368  temp1 = alpha*a( k, j )
27369  END IF
27370  DO 150, i = 1, m
27371  c( i, j ) = c( i, j ) + temp1*b( i, k )
27372  150 CONTINUE
27373  160 CONTINUE
27374  170 CONTINUE
27375  END IF
27376 *
27377  RETURN
27378 *
27379 * End of ZSYMM .
27380 *
27381  END
27382  SUBROUTINE zsyr2k( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
27383  $ beta, c, ldc )
27384 * .. Scalar Arguments ..
27385  CHARACTER*1 UPLO, TRANS
27386  INTEGER N, K, LDA, LDB, LDC
27387  COMPLEX*16 ALPHA, BETA
27388 * .. Array Arguments ..
27389  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
27390 * ..
27391 *
27392 * Purpose
27393 * =======
27394 *
27395 * ZSYR2K performs one of the symmetric rank 2k operations
27396 *
27397 * C := alpha*A*B' + alpha*B*A' + beta*C,
27398 *
27399 * or
27400 *
27401 * C := alpha*A'*B + alpha*B'*A + beta*C,
27402 *
27403 * where alpha and beta are scalars, C is an n by n symmetric matrix
27404 * and A and B are n by k matrices in the first case and k by n
27405 * matrices in the second case.
27406 *
27407 * Parameters
27408 * ==========
27409 *
27410 * UPLO - CHARACTER*1.
27411 * On entry, UPLO specifies whether the upper or lower
27412 * triangular part of the array C is to be referenced as
27413 * follows:
27414 *
27415 * UPLO = 'U' or 'u' Only the upper triangular part of C
27416 * is to be referenced.
27417 *
27418 * UPLO = 'L' or 'l' Only the lower triangular part of C
27419 * is to be referenced.
27420 *
27421 * Unchanged on exit.
27422 *
27423 * TRANS - CHARACTER*1.
27424 * On entry, TRANS specifies the operation to be performed as
27425 * follows:
27426 *
27427 * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
27428 * beta*C.
27429 *
27430 * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
27431 * beta*C.
27432 *
27433 * Unchanged on exit.
27434 *
27435 * N - INTEGER.
27436 * On entry, N specifies the order of the matrix C. N must be
27437 * at least zero.
27438 * Unchanged on exit.
27439 *
27440 * K - INTEGER.
27441 * On entry with TRANS = 'N' or 'n', K specifies the number
27442 * of columns of the matrices A and B, and on entry with
27443 * TRANS = 'T' or 't', K specifies the number of rows of the
27444 * matrices A and B. K must be at least zero.
27445 * Unchanged on exit.
27446 *
27447 * ALPHA - COMPLEX*16 .
27448 * On entry, ALPHA specifies the scalar alpha.
27449 * Unchanged on exit.
27450 *
27451 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
27452 * k when TRANS = 'N' or 'n', and is n otherwise.
27453 * Before entry with TRANS = 'N' or 'n', the leading n by k
27454 * part of the array A must contain the matrix A, otherwise
27455 * the leading k by n part of the array A must contain the
27456 * matrix A.
27457 * Unchanged on exit.
27458 *
27459 * LDA - INTEGER.
27460 * On entry, LDA specifies the first dimension of A as declared
27461 * in the calling (sub) program. When TRANS = 'N' or 'n'
27462 * then LDA must be at least max( 1, n ), otherwise LDA must
27463 * be at least max( 1, k ).
27464 * Unchanged on exit.
27465 *
27466 * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
27467 * k when TRANS = 'N' or 'n', and is n otherwise.
27468 * Before entry with TRANS = 'N' or 'n', the leading n by k
27469 * part of the array B must contain the matrix B, otherwise
27470 * the leading k by n part of the array B must contain the
27471 * matrix B.
27472 * Unchanged on exit.
27473 *
27474 * LDB - INTEGER.
27475 * On entry, LDB specifies the first dimension of B as declared
27476 * in the calling (sub) program. When TRANS = 'N' or 'n'
27477 * then LDB must be at least max( 1, n ), otherwise LDB must
27478 * be at least max( 1, k ).
27479 * Unchanged on exit.
27480 *
27481 * BETA - COMPLEX*16 .
27482 * On entry, BETA specifies the scalar beta.
27483 * Unchanged on exit.
27484 *
27485 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
27486 * Before entry with UPLO = 'U' or 'u', the leading n by n
27487 * upper triangular part of the array C must contain the upper
27488 * triangular part of the symmetric matrix and the strictly
27489 * lower triangular part of C is not referenced. On exit, the
27490 * upper triangular part of the array C is overwritten by the
27491 * upper triangular part of the updated matrix.
27492 * Before entry with UPLO = 'L' or 'l', the leading n by n
27493 * lower triangular part of the array C must contain the lower
27494 * triangular part of the symmetric matrix and the strictly
27495 * upper triangular part of C is not referenced. On exit, the
27496 * lower triangular part of the array C is overwritten by the
27497 * lower triangular part of the updated matrix.
27498 *
27499 * LDC - INTEGER.
27500 * On entry, LDC specifies the first dimension of C as declared
27501 * in the calling (sub) program. LDC must be at least
27502 * max( 1, n ).
27503 * Unchanged on exit.
27504 *
27505 *
27506 * Level 3 Blas routine.
27507 *
27508 * -- Written on 8-February-1989.
27509 * Jack Dongarra, Argonne National Laboratory.
27510 * Iain Duff, AERE Harwell.
27511 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
27512 * Sven Hammarling, Numerical Algorithms Group Ltd.
27513 *
27514 *
27515 * .. External Functions ..
27516  LOGICAL LSAME
27517  EXTERNAL lsame
27518 * .. External Subroutines ..
27519  EXTERNAL xerbla
27520 * .. Intrinsic Functions ..
27521  INTRINSIC max
27522 * .. Local Scalars ..
27523  LOGICAL UPPER
27524  INTEGER I, INFO, J, L, NROWA
27525  COMPLEX*16 TEMP1, TEMP2
27526 * .. Parameters ..
27527  COMPLEX*16 ONE
27528  parameter( one = ( 1.0d+0, 0.0d+0 ) )
27529  COMPLEX*16 ZERO
27530  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
27531 * ..
27532 * .. Executable Statements ..
27533 *
27534 * Test the input parameters.
27535 *
27536  IF( lsame( trans, 'N' ) )THEN
27537  nrowa = n
27538  ELSE
27539  nrowa = k
27540  END IF
27541  upper = lsame( uplo, 'U' )
27542 *
27543  info = 0
27544  IF( ( .NOT.upper ).AND.
27545  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
27546  info = 1
27547  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
27548  $ ( .NOT.lsame( trans, 'T' ) ) )THEN
27549  info = 2
27550  ELSE IF( n .LT.0 )THEN
27551  info = 3
27552  ELSE IF( k .LT.0 )THEN
27553  info = 4
27554  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
27555  info = 7
27556  ELSE IF( ldb.LT.max( 1, nrowa ) )THEN
27557  info = 9
27558  ELSE IF( ldc.LT.max( 1, n ) )THEN
27559  info = 12
27560  END IF
27561  IF( info.NE.0 )THEN
27562  CALL xerbla( 'ZSYR2K', info )
27563  RETURN
27564  END IF
27565 *
27566 * Quick return if possible.
27567 *
27568  IF( ( n.EQ.0 ).OR.
27569  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
27570  $ RETURN
27571 *
27572 * And when alpha.eq.zero.
27573 *
27574  IF( alpha.EQ.zero )THEN
27575  IF( upper )THEN
27576  IF( beta.EQ.zero )THEN
27577  DO 20, j = 1, n
27578  DO 10, i = 1, j
27579  c( i, j ) = zero
27580  10 CONTINUE
27581  20 CONTINUE
27582  ELSE
27583  DO 40, j = 1, n
27584  DO 30, i = 1, j
27585  c( i, j ) = beta*c( i, j )
27586  30 CONTINUE
27587  40 CONTINUE
27588  END IF
27589  ELSE
27590  IF( beta.EQ.zero )THEN
27591  DO 60, j = 1, n
27592  DO 50, i = j, n
27593  c( i, j ) = zero
27594  50 CONTINUE
27595  60 CONTINUE
27596  ELSE
27597  DO 80, j = 1, n
27598  DO 70, i = j, n
27599  c( i, j ) = beta*c( i, j )
27600  70 CONTINUE
27601  80 CONTINUE
27602  END IF
27603  END IF
27604  RETURN
27605  END IF
27606 *
27607 * Start the operations.
27608 *
27609  IF( lsame( trans, 'N' ) )THEN
27610 *
27611 * Form C := alpha*A*B' + alpha*B*A' + C.
27612 *
27613  IF( upper )THEN
27614  DO 130, j = 1, n
27615  IF( beta.EQ.zero )THEN
27616  DO 90, i = 1, j
27617  c( i, j ) = zero
27618  90 CONTINUE
27619  ELSE IF( beta.NE.one )THEN
27620  DO 100, i = 1, j
27621  c( i, j ) = beta*c( i, j )
27622  100 CONTINUE
27623  END IF
27624  DO 120, l = 1, k
27625  IF( ( a( j, l ).NE.zero ).OR.
27626  $ ( b( j, l ).NE.zero ) )THEN
27627  temp1 = alpha*b( j, l )
27628  temp2 = alpha*a( j, l )
27629  DO 110, i = 1, j
27630  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
27631  $ b( i, l )*temp2
27632  110 CONTINUE
27633  END IF
27634  120 CONTINUE
27635  130 CONTINUE
27636  ELSE
27637  DO 180, j = 1, n
27638  IF( beta.EQ.zero )THEN
27639  DO 140, i = j, n
27640  c( i, j ) = zero
27641  140 CONTINUE
27642  ELSE IF( beta.NE.one )THEN
27643  DO 150, i = j, n
27644  c( i, j ) = beta*c( i, j )
27645  150 CONTINUE
27646  END IF
27647  DO 170, l = 1, k
27648  IF( ( a( j, l ).NE.zero ).OR.
27649  $ ( b( j, l ).NE.zero ) )THEN
27650  temp1 = alpha*b( j, l )
27651  temp2 = alpha*a( j, l )
27652  DO 160, i = j, n
27653  c( i, j ) = c( i, j ) + a( i, l )*temp1 +
27654  $ b( i, l )*temp2
27655  160 CONTINUE
27656  END IF
27657  170 CONTINUE
27658  180 CONTINUE
27659  END IF
27660  ELSE
27661 *
27662 * Form C := alpha*A'*B + alpha*B'*A + C.
27663 *
27664  IF( upper )THEN
27665  DO 210, j = 1, n
27666  DO 200, i = 1, j
27667  temp1 = zero
27668  temp2 = zero
27669  DO 190, l = 1, k
27670  temp1 = temp1 + a( l, i )*b( l, j )
27671  temp2 = temp2 + b( l, i )*a( l, j )
27672  190 CONTINUE
27673  IF( beta.EQ.zero )THEN
27674  c( i, j ) = alpha*temp1 + alpha*temp2
27675  ELSE
27676  c( i, j ) = beta *c( i, j ) +
27677  $ alpha*temp1 + alpha*temp2
27678  END IF
27679  200 CONTINUE
27680  210 CONTINUE
27681  ELSE
27682  DO 240, j = 1, n
27683  DO 230, i = j, n
27684  temp1 = zero
27685  temp2 = zero
27686  DO 220, l = 1, k
27687  temp1 = temp1 + a( l, i )*b( l, j )
27688  temp2 = temp2 + b( l, i )*a( l, j )
27689  220 CONTINUE
27690  IF( beta.EQ.zero )THEN
27691  c( i, j ) = alpha*temp1 + alpha*temp2
27692  ELSE
27693  c( i, j ) = beta *c( i, j ) +
27694  $ alpha*temp1 + alpha*temp2
27695  END IF
27696  230 CONTINUE
27697  240 CONTINUE
27698  END IF
27699  END IF
27700 *
27701  RETURN
27702 *
27703 * End of ZSYR2K.
27704 *
27705  END
27706  SUBROUTINE zsyrk ( UPLO, TRANS, N, K, ALPHA, A, LDA,
27707  $ beta, c, ldc )
27708 * .. Scalar Arguments ..
27709  CHARACTER*1 UPLO, TRANS
27710  INTEGER N, K, LDA, LDC
27711  COMPLEX*16 ALPHA, BETA
27712 * .. Array Arguments ..
27713  COMPLEX*16 A( lda, * ), C( ldc, * )
27714 * ..
27715 *
27716 * Purpose
27717 * =======
27718 *
27719 * ZSYRK performs one of the symmetric rank k operations
27720 *
27721 * C := alpha*A*A' + beta*C,
27722 *
27723 * or
27724 *
27725 * C := alpha*A'*A + beta*C,
27726 *
27727 * where alpha and beta are scalars, C is an n by n symmetric matrix
27728 * and A is an n by k matrix in the first case and a k by n matrix
27729 * in the second case.
27730 *
27731 * Parameters
27732 * ==========
27733 *
27734 * UPLO - CHARACTER*1.
27735 * On entry, UPLO specifies whether the upper or lower
27736 * triangular part of the array C is to be referenced as
27737 * follows:
27738 *
27739 * UPLO = 'U' or 'u' Only the upper triangular part of C
27740 * is to be referenced.
27741 *
27742 * UPLO = 'L' or 'l' Only the lower triangular part of C
27743 * is to be referenced.
27744 *
27745 * Unchanged on exit.
27746 *
27747 * TRANS - CHARACTER*1.
27748 * On entry, TRANS specifies the operation to be performed as
27749 * follows:
27750 *
27751 * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
27752 *
27753 * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
27754 *
27755 * Unchanged on exit.
27756 *
27757 * N - INTEGER.
27758 * On entry, N specifies the order of the matrix C. N must be
27759 * at least zero.
27760 * Unchanged on exit.
27761 *
27762 * K - INTEGER.
27763 * On entry with TRANS = 'N' or 'n', K specifies the number
27764 * of columns of the matrix A, and on entry with
27765 * TRANS = 'T' or 't', K specifies the number of rows of the
27766 * matrix A. K must be at least zero.
27767 * Unchanged on exit.
27768 *
27769 * ALPHA - COMPLEX*16 .
27770 * On entry, ALPHA specifies the scalar alpha.
27771 * Unchanged on exit.
27772 *
27773 * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
27774 * k when TRANS = 'N' or 'n', and is n otherwise.
27775 * Before entry with TRANS = 'N' or 'n', the leading n by k
27776 * part of the array A must contain the matrix A, otherwise
27777 * the leading k by n part of the array A must contain the
27778 * matrix A.
27779 * Unchanged on exit.
27780 *
27781 * LDA - INTEGER.
27782 * On entry, LDA specifies the first dimension of A as declared
27783 * in the calling (sub) program. When TRANS = 'N' or 'n'
27784 * then LDA must be at least max( 1, n ), otherwise LDA must
27785 * be at least max( 1, k ).
27786 * Unchanged on exit.
27787 *
27788 * BETA - COMPLEX*16 .
27789 * On entry, BETA specifies the scalar beta.
27790 * Unchanged on exit.
27791 *
27792 * C - COMPLEX*16 array of DIMENSION ( LDC, n ).
27793 * Before entry with UPLO = 'U' or 'u', the leading n by n
27794 * upper triangular part of the array C must contain the upper
27795 * triangular part of the symmetric matrix and the strictly
27796 * lower triangular part of C is not referenced. On exit, the
27797 * upper triangular part of the array C is overwritten by the
27798 * upper triangular part of the updated matrix.
27799 * Before entry with UPLO = 'L' or 'l', the leading n by n
27800 * lower triangular part of the array C must contain the lower
27801 * triangular part of the symmetric matrix and the strictly
27802 * upper triangular part of C is not referenced. On exit, the
27803 * lower triangular part of the array C is overwritten by the
27804 * lower triangular part of the updated matrix.
27805 *
27806 * LDC - INTEGER.
27807 * On entry, LDC specifies the first dimension of C as declared
27808 * in the calling (sub) program. LDC must be at least
27809 * max( 1, n ).
27810 * Unchanged on exit.
27811 *
27812 *
27813 * Level 3 Blas routine.
27814 *
27815 * -- Written on 8-February-1989.
27816 * Jack Dongarra, Argonne National Laboratory.
27817 * Iain Duff, AERE Harwell.
27818 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
27819 * Sven Hammarling, Numerical Algorithms Group Ltd.
27820 *
27821 *
27822 * .. External Functions ..
27823  LOGICAL LSAME
27824  EXTERNAL lsame
27825 * .. External Subroutines ..
27826  EXTERNAL xerbla
27827 * .. Intrinsic Functions ..
27828  INTRINSIC max
27829 * .. Local Scalars ..
27830  LOGICAL UPPER
27831  INTEGER I, INFO, J, L, NROWA
27832  COMPLEX*16 TEMP
27833 * .. Parameters ..
27834  COMPLEX*16 ONE
27835  parameter( one = ( 1.0d+0, 0.0d+0 ) )
27836  COMPLEX*16 ZERO
27837  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
27838 * ..
27839 * .. Executable Statements ..
27840 *
27841 * Test the input parameters.
27842 *
27843  IF( lsame( trans, 'N' ) )THEN
27844  nrowa = n
27845  ELSE
27846  nrowa = k
27847  END IF
27848  upper = lsame( uplo, 'U' )
27849 *
27850  info = 0
27851  IF( ( .NOT.upper ).AND.
27852  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
27853  info = 1
27854  ELSE IF( ( .NOT.lsame( trans, 'N' ) ).AND.
27855  $ ( .NOT.lsame( trans, 'T' ) ) )THEN
27856  info = 2
27857  ELSE IF( n .LT.0 )THEN
27858  info = 3
27859  ELSE IF( k .LT.0 )THEN
27860  info = 4
27861  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
27862  info = 7
27863  ELSE IF( ldc.LT.max( 1, n ) )THEN
27864  info = 10
27865  END IF
27866  IF( info.NE.0 )THEN
27867  CALL xerbla( 'ZSYRK ', info )
27868  RETURN
27869  END IF
27870 *
27871 * Quick return if possible.
27872 *
27873  IF( ( n.EQ.0 ).OR.
27874  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
27875  $ RETURN
27876 *
27877 * And when alpha.eq.zero.
27878 *
27879  IF( alpha.EQ.zero )THEN
27880  IF( upper )THEN
27881  IF( beta.EQ.zero )THEN
27882  DO 20, j = 1, n
27883  DO 10, i = 1, j
27884  c( i, j ) = zero
27885  10 CONTINUE
27886  20 CONTINUE
27887  ELSE
27888  DO 40, j = 1, n
27889  DO 30, i = 1, j
27890  c( i, j ) = beta*c( i, j )
27891  30 CONTINUE
27892  40 CONTINUE
27893  END IF
27894  ELSE
27895  IF( beta.EQ.zero )THEN
27896  DO 60, j = 1, n
27897  DO 50, i = j, n
27898  c( i, j ) = zero
27899  50 CONTINUE
27900  60 CONTINUE
27901  ELSE
27902  DO 80, j = 1, n
27903  DO 70, i = j, n
27904  c( i, j ) = beta*c( i, j )
27905  70 CONTINUE
27906  80 CONTINUE
27907  END IF
27908  END IF
27909  RETURN
27910  END IF
27911 *
27912 * Start the operations.
27913 *
27914  IF( lsame( trans, 'N' ) )THEN
27915 *
27916 * Form C := alpha*A*A' + beta*C.
27917 *
27918  IF( upper )THEN
27919  DO 130, j = 1, n
27920  IF( beta.EQ.zero )THEN
27921  DO 90, i = 1, j
27922  c( i, j ) = zero
27923  90 CONTINUE
27924  ELSE IF( beta.NE.one )THEN
27925  DO 100, i = 1, j
27926  c( i, j ) = beta*c( i, j )
27927  100 CONTINUE
27928  END IF
27929  DO 120, l = 1, k
27930  IF( a( j, l ).NE.zero )THEN
27931  temp = alpha*a( j, l )
27932  DO 110, i = 1, j
27933  c( i, j ) = c( i, j ) + temp*a( i, l )
27934  110 CONTINUE
27935  END IF
27936  120 CONTINUE
27937  130 CONTINUE
27938  ELSE
27939  DO 180, j = 1, n
27940  IF( beta.EQ.zero )THEN
27941  DO 140, i = j, n
27942  c( i, j ) = zero
27943  140 CONTINUE
27944  ELSE IF( beta.NE.one )THEN
27945  DO 150, i = j, n
27946  c( i, j ) = beta*c( i, j )
27947  150 CONTINUE
27948  END IF
27949  DO 170, l = 1, k
27950  IF( a( j, l ).NE.zero )THEN
27951  temp = alpha*a( j, l )
27952  DO 160, i = j, n
27953  c( i, j ) = c( i, j ) + temp*a( i, l )
27954  160 CONTINUE
27955  END IF
27956  170 CONTINUE
27957  180 CONTINUE
27958  END IF
27959  ELSE
27960 *
27961 * Form C := alpha*A'*A + beta*C.
27962 *
27963  IF( upper )THEN
27964  DO 210, j = 1, n
27965  DO 200, i = 1, j
27966  temp = zero
27967  DO 190, l = 1, k
27968  temp = temp + a( l, i )*a( l, j )
27969  190 CONTINUE
27970  IF( beta.EQ.zero )THEN
27971  c( i, j ) = alpha*temp
27972  ELSE
27973  c( i, j ) = alpha*temp + beta*c( i, j )
27974  END IF
27975  200 CONTINUE
27976  210 CONTINUE
27977  ELSE
27978  DO 240, j = 1, n
27979  DO 230, i = j, n
27980  temp = zero
27981  DO 220, l = 1, k
27982  temp = temp + a( l, i )*a( l, j )
27983  220 CONTINUE
27984  IF( beta.EQ.zero )THEN
27985  c( i, j ) = alpha*temp
27986  ELSE
27987  c( i, j ) = alpha*temp + beta*c( i, j )
27988  END IF
27989  230 CONTINUE
27990  240 CONTINUE
27991  END IF
27992  END IF
27993 *
27994  RETURN
27995 *
27996 * End of ZSYRK .
27997 *
27998  END
27999  SUBROUTINE ztbmv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
28000 * .. Scalar Arguments ..
28001  INTEGER INCX, K, LDA, N
28002  CHARACTER*1 DIAG, TRANS, UPLO
28003 * .. Array Arguments ..
28004  COMPLEX*16 A( lda, * ), X( * )
28005 * ..
28006 *
28007 * Purpose
28008 * =======
28009 *
28010 * ZTBMV performs one of the matrix-vector operations
28011 *
28012 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
28013 *
28014 * where x is an n element vector and A is an n by n unit, or non-unit,
28015 * upper or lower triangular band matrix, with ( k + 1 ) diagonals.
28016 *
28017 * Parameters
28018 * ==========
28019 *
28020 * UPLO - CHARACTER*1.
28021 * On entry, UPLO specifies whether the matrix is an upper or
28022 * lower triangular matrix as follows:
28023 *
28024 * UPLO = 'U' or 'u' A is an upper triangular matrix.
28025 *
28026 * UPLO = 'L' or 'l' A is a lower triangular matrix.
28027 *
28028 * Unchanged on exit.
28029 *
28030 * TRANS - CHARACTER*1.
28031 * On entry, TRANS specifies the operation to be performed as
28032 * follows:
28033 *
28034 * TRANS = 'N' or 'n' x := A*x.
28035 *
28036 * TRANS = 'T' or 't' x := A'*x.
28037 *
28038 * TRANS = 'C' or 'c' x := conjg( A' )*x.
28039 *
28040 * Unchanged on exit.
28041 *
28042 * DIAG - CHARACTER*1.
28043 * On entry, DIAG specifies whether or not A is unit
28044 * triangular as follows:
28045 *
28046 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
28047 *
28048 * DIAG = 'N' or 'n' A is not assumed to be unit
28049 * triangular.
28050 *
28051 * Unchanged on exit.
28052 *
28053 * N - INTEGER.
28054 * On entry, N specifies the order of the matrix A.
28055 * N must be at least zero.
28056 * Unchanged on exit.
28057 *
28058 * K - INTEGER.
28059 * On entry with UPLO = 'U' or 'u', K specifies the number of
28060 * super-diagonals of the matrix A.
28061 * On entry with UPLO = 'L' or 'l', K specifies the number of
28062 * sub-diagonals of the matrix A.
28063 * K must satisfy 0 .le. K.
28064 * Unchanged on exit.
28065 *
28066 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
28067 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
28068 * by n part of the array A must contain the upper triangular
28069 * band part of the matrix of coefficients, supplied column by
28070 * column, with the leading diagonal of the matrix in row
28071 * ( k + 1 ) of the array, the first super-diagonal starting at
28072 * position 2 in row k, and so on. The top left k by k triangle
28073 * of the array A is not referenced.
28074 * The following program segment will transfer an upper
28075 * triangular band matrix from conventional full matrix storage
28076 * to band storage:
28077 *
28078 * DO 20, J = 1, N
28079 * M = K + 1 - J
28080 * DO 10, I = MAX( 1, J - K ), J
28081 * A( M + I, J ) = matrix( I, J )
28082 * 10 CONTINUE
28083 * 20 CONTINUE
28084 *
28085 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
28086 * by n part of the array A must contain the lower triangular
28087 * band part of the matrix of coefficients, supplied column by
28088 * column, with the leading diagonal of the matrix in row 1 of
28089 * the array, the first sub-diagonal starting at position 1 in
28090 * row 2, and so on. The bottom right k by k triangle of the
28091 * array A is not referenced.
28092 * The following program segment will transfer a lower
28093 * triangular band matrix from conventional full matrix storage
28094 * to band storage:
28095 *
28096 * DO 20, J = 1, N
28097 * M = 1 - J
28098 * DO 10, I = J, MIN( N, J + K )
28099 * A( M + I, J ) = matrix( I, J )
28100 * 10 CONTINUE
28101 * 20 CONTINUE
28102 *
28103 * Note that when DIAG = 'U' or 'u' the elements of the array A
28104 * corresponding to the diagonal elements of the matrix are not
28105 * referenced, but are assumed to be unity.
28106 * Unchanged on exit.
28107 *
28108 * LDA - INTEGER.
28109 * On entry, LDA specifies the first dimension of A as declared
28110 * in the calling (sub) program. LDA must be at least
28111 * ( k + 1 ).
28112 * Unchanged on exit.
28113 *
28114 * X - COMPLEX*16 array of dimension at least
28115 * ( 1 + ( n - 1 )*abs( INCX ) ).
28116 * Before entry, the incremented array X must contain the n
28117 * element vector x. On exit, X is overwritten with the
28118 * tranformed vector x.
28119 *
28120 * INCX - INTEGER.
28121 * On entry, INCX specifies the increment for the elements of
28122 * X. INCX must not be zero.
28123 * Unchanged on exit.
28124 *
28125 *
28126 * Level 2 Blas routine.
28127 *
28128 * -- Written on 22-October-1986.
28129 * Jack Dongarra, Argonne National Lab.
28130 * Jeremy Du Croz, Nag Central Office.
28131 * Sven Hammarling, Nag Central Office.
28132 * Richard Hanson, Sandia National Labs.
28133 *
28134 *
28135 * .. Parameters ..
28136  COMPLEX*16 ZERO
28137  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
28138 * .. Local Scalars ..
28139  COMPLEX*16 TEMP
28140  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
28141  LOGICAL NOCONJ, NOUNIT
28142 * .. External Functions ..
28143  LOGICAL LSAME
28144  EXTERNAL lsame
28145 * .. External Subroutines ..
28146  EXTERNAL xerbla
28147 * .. Intrinsic Functions ..
28148  INTRINSIC dconjg, max, min
28149 * ..
28150 * .. Executable Statements ..
28151 *
28152 * Test the input parameters.
28153 *
28154  info = 0
28155  IF ( .NOT.lsame( uplo , 'U' ).AND.
28156  $ .NOT.lsame( uplo , 'L' ) )THEN
28157  info = 1
28158  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
28159  $ .NOT.lsame( trans, 'T' ).AND.
28160  $ .NOT.lsame( trans, 'C' ) )THEN
28161  info = 2
28162  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
28163  $ .NOT.lsame( diag , 'N' ) )THEN
28164  info = 3
28165  ELSE IF( n.LT.0 )THEN
28166  info = 4
28167  ELSE IF( k.LT.0 )THEN
28168  info = 5
28169  ELSE IF( lda.LT.( k + 1 ) )THEN
28170  info = 7
28171  ELSE IF( incx.EQ.0 )THEN
28172  info = 9
28173  END IF
28174  IF( info.NE.0 )THEN
28175  CALL xerbla( 'ZTBMV ', info )
28176  RETURN
28177  END IF
28178 *
28179 * Quick return if possible.
28180 *
28181  IF( n.EQ.0 )
28182  $ RETURN
28183 *
28184  noconj = lsame( trans, 'T' )
28185  nounit = lsame( diag , 'N' )
28186 *
28187 * Set up the start point in X if the increment is not unity. This
28188 * will be ( N - 1 )*INCX too small for descending loops.
28189 *
28190  IF( incx.LE.0 )THEN
28191  kx = 1 - ( n - 1 )*incx
28192  ELSE IF( incx.NE.1 )THEN
28193  kx = 1
28194  END IF
28195 *
28196 * Start the operations. In this version the elements of A are
28197 * accessed sequentially with one pass through A.
28198 *
28199  IF( lsame( trans, 'N' ) )THEN
28200 *
28201 * Form x := A*x.
28202 *
28203  IF( lsame( uplo, 'U' ) )THEN
28204  kplus1 = k + 1
28205  IF( incx.EQ.1 )THEN
28206  DO 20, j = 1, n
28207  IF( x( j ).NE.zero )THEN
28208  temp = x( j )
28209  l = kplus1 - j
28210  DO 10, i = max( 1, j - k ), j - 1
28211  x( i ) = x( i ) + temp*a( l + i, j )
28212  10 CONTINUE
28213  IF( nounit )
28214  $ x( j ) = x( j )*a( kplus1, j )
28215  END IF
28216  20 CONTINUE
28217  ELSE
28218  jx = kx
28219  DO 40, j = 1, n
28220  IF( x( jx ).NE.zero )THEN
28221  temp = x( jx )
28222  ix = kx
28223  l = kplus1 - j
28224  DO 30, i = max( 1, j - k ), j - 1
28225  x( ix ) = x( ix ) + temp*a( l + i, j )
28226  ix = ix + incx
28227  30 CONTINUE
28228  IF( nounit )
28229  $ x( jx ) = x( jx )*a( kplus1, j )
28230  END IF
28231  jx = jx + incx
28232  IF( j.GT.k )
28233  $ kx = kx + incx
28234  40 CONTINUE
28235  END IF
28236  ELSE
28237  IF( incx.EQ.1 )THEN
28238  DO 60, j = n, 1, -1
28239  IF( x( j ).NE.zero )THEN
28240  temp = x( j )
28241  l = 1 - j
28242  DO 50, i = min( n, j + k ), j + 1, -1
28243  x( i ) = x( i ) + temp*a( l + i, j )
28244  50 CONTINUE
28245  IF( nounit )
28246  $ x( j ) = x( j )*a( 1, j )
28247  END IF
28248  60 CONTINUE
28249  ELSE
28250  kx = kx + ( n - 1 )*incx
28251  jx = kx
28252  DO 80, j = n, 1, -1
28253  IF( x( jx ).NE.zero )THEN
28254  temp = x( jx )
28255  ix = kx
28256  l = 1 - j
28257  DO 70, i = min( n, j + k ), j + 1, -1
28258  x( ix ) = x( ix ) + temp*a( l + i, j )
28259  ix = ix - incx
28260  70 CONTINUE
28261  IF( nounit )
28262  $ x( jx ) = x( jx )*a( 1, j )
28263  END IF
28264  jx = jx - incx
28265  IF( ( n - j ).GE.k )
28266  $ kx = kx - incx
28267  80 CONTINUE
28268  END IF
28269  END IF
28270  ELSE
28271 *
28272 * Form x := A'*x or x := conjg( A' )*x.
28273 *
28274  IF( lsame( uplo, 'U' ) )THEN
28275  kplus1 = k + 1
28276  IF( incx.EQ.1 )THEN
28277  DO 110, j = n, 1, -1
28278  temp = x( j )
28279  l = kplus1 - j
28280  IF( noconj )THEN
28281  IF( nounit )
28282  $ temp = temp*a( kplus1, j )
28283  DO 90, i = j - 1, max( 1, j - k ), -1
28284  temp = temp + a( l + i, j )*x( i )
28285  90 CONTINUE
28286  ELSE
28287  IF( nounit )
28288  $ temp = temp*dconjg( a( kplus1, j ) )
28289  DO 100, i = j - 1, max( 1, j - k ), -1
28290  temp = temp + dconjg( a( l + i, j ) )*x( i )
28291  100 CONTINUE
28292  END IF
28293  x( j ) = temp
28294  110 CONTINUE
28295  ELSE
28296  kx = kx + ( n - 1 )*incx
28297  jx = kx
28298  DO 140, j = n, 1, -1
28299  temp = x( jx )
28300  kx = kx - incx
28301  ix = kx
28302  l = kplus1 - j
28303  IF( noconj )THEN
28304  IF( nounit )
28305  $ temp = temp*a( kplus1, j )
28306  DO 120, i = j - 1, max( 1, j - k ), -1
28307  temp = temp + a( l + i, j )*x( ix )
28308  ix = ix - incx
28309  120 CONTINUE
28310  ELSE
28311  IF( nounit )
28312  $ temp = temp*dconjg( a( kplus1, j ) )
28313  DO 130, i = j - 1, max( 1, j - k ), -1
28314  temp = temp + dconjg( a( l + i, j ) )*x( ix )
28315  ix = ix - incx
28316  130 CONTINUE
28317  END IF
28318  x( jx ) = temp
28319  jx = jx - incx
28320  140 CONTINUE
28321  END IF
28322  ELSE
28323  IF( incx.EQ.1 )THEN
28324  DO 170, j = 1, n
28325  temp = x( j )
28326  l = 1 - j
28327  IF( noconj )THEN
28328  IF( nounit )
28329  $ temp = temp*a( 1, j )
28330  DO 150, i = j + 1, min( n, j + k )
28331  temp = temp + a( l + i, j )*x( i )
28332  150 CONTINUE
28333  ELSE
28334  IF( nounit )
28335  $ temp = temp*dconjg( a( 1, j ) )
28336  DO 160, i = j + 1, min( n, j + k )
28337  temp = temp + dconjg( a( l + i, j ) )*x( i )
28338  160 CONTINUE
28339  END IF
28340  x( j ) = temp
28341  170 CONTINUE
28342  ELSE
28343  jx = kx
28344  DO 200, j = 1, n
28345  temp = x( jx )
28346  kx = kx + incx
28347  ix = kx
28348  l = 1 - j
28349  IF( noconj )THEN
28350  IF( nounit )
28351  $ temp = temp*a( 1, j )
28352  DO 180, i = j + 1, min( n, j + k )
28353  temp = temp + a( l + i, j )*x( ix )
28354  ix = ix + incx
28355  180 CONTINUE
28356  ELSE
28357  IF( nounit )
28358  $ temp = temp*dconjg( a( 1, j ) )
28359  DO 190, i = j + 1, min( n, j + k )
28360  temp = temp + dconjg( a( l + i, j ) )*x( ix )
28361  ix = ix + incx
28362  190 CONTINUE
28363  END IF
28364  x( jx ) = temp
28365  jx = jx + incx
28366  200 CONTINUE
28367  END IF
28368  END IF
28369  END IF
28370 *
28371  RETURN
28372 *
28373 * End of ZTBMV .
28374 *
28375  END
28376  SUBROUTINE ztbsv ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
28377 * .. Scalar Arguments ..
28378  INTEGER INCX, K, LDA, N
28379  CHARACTER*1 DIAG, TRANS, UPLO
28380 * .. Array Arguments ..
28381  COMPLEX*16 A( lda, * ), X( * )
28382 * ..
28383 *
28384 * Purpose
28385 * =======
28386 *
28387 * ZTBSV solves one of the systems of equations
28388 *
28389 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
28390 *
28391 * where b and x are n element vectors and A is an n by n unit, or
28392 * non-unit, upper or lower triangular band matrix, with ( k + 1 )
28393 * diagonals.
28394 *
28395 * No test for singularity or near-singularity is included in this
28396 * routine. Such tests must be performed before calling this routine.
28397 *
28398 * Parameters
28399 * ==========
28400 *
28401 * UPLO - CHARACTER*1.
28402 * On entry, UPLO specifies whether the matrix is an upper or
28403 * lower triangular matrix as follows:
28404 *
28405 * UPLO = 'U' or 'u' A is an upper triangular matrix.
28406 *
28407 * UPLO = 'L' or 'l' A is a lower triangular matrix.
28408 *
28409 * Unchanged on exit.
28410 *
28411 * TRANS - CHARACTER*1.
28412 * On entry, TRANS specifies the equations to be solved as
28413 * follows:
28414 *
28415 * TRANS = 'N' or 'n' A*x = b.
28416 *
28417 * TRANS = 'T' or 't' A'*x = b.
28418 *
28419 * TRANS = 'C' or 'c' conjg( A' )*x = b.
28420 *
28421 * Unchanged on exit.
28422 *
28423 * DIAG - CHARACTER*1.
28424 * On entry, DIAG specifies whether or not A is unit
28425 * triangular as follows:
28426 *
28427 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
28428 *
28429 * DIAG = 'N' or 'n' A is not assumed to be unit
28430 * triangular.
28431 *
28432 * Unchanged on exit.
28433 *
28434 * N - INTEGER.
28435 * On entry, N specifies the order of the matrix A.
28436 * N must be at least zero.
28437 * Unchanged on exit.
28438 *
28439 * K - INTEGER.
28440 * On entry with UPLO = 'U' or 'u', K specifies the number of
28441 * super-diagonals of the matrix A.
28442 * On entry with UPLO = 'L' or 'l', K specifies the number of
28443 * sub-diagonals of the matrix A.
28444 * K must satisfy 0 .le. K.
28445 * Unchanged on exit.
28446 *
28447 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
28448 * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
28449 * by n part of the array A must contain the upper triangular
28450 * band part of the matrix of coefficients, supplied column by
28451 * column, with the leading diagonal of the matrix in row
28452 * ( k + 1 ) of the array, the first super-diagonal starting at
28453 * position 2 in row k, and so on. The top left k by k triangle
28454 * of the array A is not referenced.
28455 * The following program segment will transfer an upper
28456 * triangular band matrix from conventional full matrix storage
28457 * to band storage:
28458 *
28459 * DO 20, J = 1, N
28460 * M = K + 1 - J
28461 * DO 10, I = MAX( 1, J - K ), J
28462 * A( M + I, J ) = matrix( I, J )
28463 * 10 CONTINUE
28464 * 20 CONTINUE
28465 *
28466 * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
28467 * by n part of the array A must contain the lower triangular
28468 * band part of the matrix of coefficients, supplied column by
28469 * column, with the leading diagonal of the matrix in row 1 of
28470 * the array, the first sub-diagonal starting at position 1 in
28471 * row 2, and so on. The bottom right k by k triangle of the
28472 * array A is not referenced.
28473 * The following program segment will transfer a lower
28474 * triangular band matrix from conventional full matrix storage
28475 * to band storage:
28476 *
28477 * DO 20, J = 1, N
28478 * M = 1 - J
28479 * DO 10, I = J, MIN( N, J + K )
28480 * A( M + I, J ) = matrix( I, J )
28481 * 10 CONTINUE
28482 * 20 CONTINUE
28483 *
28484 * Note that when DIAG = 'U' or 'u' the elements of the array A
28485 * corresponding to the diagonal elements of the matrix are not
28486 * referenced, but are assumed to be unity.
28487 * Unchanged on exit.
28488 *
28489 * LDA - INTEGER.
28490 * On entry, LDA specifies the first dimension of A as declared
28491 * in the calling (sub) program. LDA must be at least
28492 * ( k + 1 ).
28493 * Unchanged on exit.
28494 *
28495 * X - COMPLEX*16 array of dimension at least
28496 * ( 1 + ( n - 1 )*abs( INCX ) ).
28497 * Before entry, the incremented array X must contain the n
28498 * element right-hand side vector b. On exit, X is overwritten
28499 * with the solution vector x.
28500 *
28501 * INCX - INTEGER.
28502 * On entry, INCX specifies the increment for the elements of
28503 * X. INCX must not be zero.
28504 * Unchanged on exit.
28505 *
28506 *
28507 * Level 2 Blas routine.
28508 *
28509 * -- Written on 22-October-1986.
28510 * Jack Dongarra, Argonne National Lab.
28511 * Jeremy Du Croz, Nag Central Office.
28512 * Sven Hammarling, Nag Central Office.
28513 * Richard Hanson, Sandia National Labs.
28514 *
28515 *
28516 * .. Parameters ..
28517  COMPLEX*16 ZERO
28518  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
28519 * .. Local Scalars ..
28520  COMPLEX*16 TEMP
28521  INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
28522  LOGICAL NOCONJ, NOUNIT
28523 * .. External Functions ..
28524  LOGICAL LSAME
28525  EXTERNAL lsame
28526 * .. External Subroutines ..
28527  EXTERNAL xerbla
28528 * .. Intrinsic Functions ..
28529  INTRINSIC dconjg, max, min
28530 * ..
28531 * .. Executable Statements ..
28532 *
28533 * Test the input parameters.
28534 *
28535  info = 0
28536  IF ( .NOT.lsame( uplo , 'U' ).AND.
28537  $ .NOT.lsame( uplo , 'L' ) )THEN
28538  info = 1
28539  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
28540  $ .NOT.lsame( trans, 'T' ).AND.
28541  $ .NOT.lsame( trans, 'C' ) )THEN
28542  info = 2
28543  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
28544  $ .NOT.lsame( diag , 'N' ) )THEN
28545  info = 3
28546  ELSE IF( n.LT.0 )THEN
28547  info = 4
28548  ELSE IF( k.LT.0 )THEN
28549  info = 5
28550  ELSE IF( lda.LT.( k + 1 ) )THEN
28551  info = 7
28552  ELSE IF( incx.EQ.0 )THEN
28553  info = 9
28554  END IF
28555  IF( info.NE.0 )THEN
28556  CALL xerbla( 'ZTBSV ', info )
28557  RETURN
28558  END IF
28559 *
28560 * Quick return if possible.
28561 *
28562  IF( n.EQ.0 )
28563  $ RETURN
28564 *
28565  noconj = lsame( trans, 'T' )
28566  nounit = lsame( diag , 'N' )
28567 *
28568 * Set up the start point in X if the increment is not unity. This
28569 * will be ( N - 1 )*INCX too small for descending loops.
28570 *
28571  IF( incx.LE.0 )THEN
28572  kx = 1 - ( n - 1 )*incx
28573  ELSE IF( incx.NE.1 )THEN
28574  kx = 1
28575  END IF
28576 *
28577 * Start the operations. In this version the elements of A are
28578 * accessed by sequentially with one pass through A.
28579 *
28580  IF( lsame( trans, 'N' ) )THEN
28581 *
28582 * Form x := inv( A )*x.
28583 *
28584  IF( lsame( uplo, 'U' ) )THEN
28585  kplus1 = k + 1
28586  IF( incx.EQ.1 )THEN
28587  DO 20, j = n, 1, -1
28588  IF( x( j ).NE.zero )THEN
28589  l = kplus1 - j
28590  IF( nounit )
28591  $ x( j ) = x( j )/a( kplus1, j )
28592  temp = x( j )
28593  DO 10, i = j - 1, max( 1, j - k ), -1
28594  x( i ) = x( i ) - temp*a( l + i, j )
28595  10 CONTINUE
28596  END IF
28597  20 CONTINUE
28598  ELSE
28599  kx = kx + ( n - 1 )*incx
28600  jx = kx
28601  DO 40, j = n, 1, -1
28602  kx = kx - incx
28603  IF( x( jx ).NE.zero )THEN
28604  ix = kx
28605  l = kplus1 - j
28606  IF( nounit )
28607  $ x( jx ) = x( jx )/a( kplus1, j )
28608  temp = x( jx )
28609  DO 30, i = j - 1, max( 1, j - k ), -1
28610  x( ix ) = x( ix ) - temp*a( l + i, j )
28611  ix = ix - incx
28612  30 CONTINUE
28613  END IF
28614  jx = jx - incx
28615  40 CONTINUE
28616  END IF
28617  ELSE
28618  IF( incx.EQ.1 )THEN
28619  DO 60, j = 1, n
28620  IF( x( j ).NE.zero )THEN
28621  l = 1 - j
28622  IF( nounit )
28623  $ x( j ) = x( j )/a( 1, j )
28624  temp = x( j )
28625  DO 50, i = j + 1, min( n, j + k )
28626  x( i ) = x( i ) - temp*a( l + i, j )
28627  50 CONTINUE
28628  END IF
28629  60 CONTINUE
28630  ELSE
28631  jx = kx
28632  DO 80, j = 1, n
28633  kx = kx + incx
28634  IF( x( jx ).NE.zero )THEN
28635  ix = kx
28636  l = 1 - j
28637  IF( nounit )
28638  $ x( jx ) = x( jx )/a( 1, j )
28639  temp = x( jx )
28640  DO 70, i = j + 1, min( n, j + k )
28641  x( ix ) = x( ix ) - temp*a( l + i, j )
28642  ix = ix + incx
28643  70 CONTINUE
28644  END IF
28645  jx = jx + incx
28646  80 CONTINUE
28647  END IF
28648  END IF
28649  ELSE
28650 *
28651 * Form x := inv( A' )*x or x := inv( conjg( A') )*x.
28652 *
28653  IF( lsame( uplo, 'U' ) )THEN
28654  kplus1 = k + 1
28655  IF( incx.EQ.1 )THEN
28656  DO 110, j = 1, n
28657  temp = x( j )
28658  l = kplus1 - j
28659  IF( noconj )THEN
28660  DO 90, i = max( 1, j - k ), j - 1
28661  temp = temp - a( l + i, j )*x( i )
28662  90 CONTINUE
28663  IF( nounit )
28664  $ temp = temp/a( kplus1, j )
28665  ELSE
28666  DO 100, i = max( 1, j - k ), j - 1
28667  temp = temp - dconjg( a( l + i, j ) )*x( i )
28668  100 CONTINUE
28669  IF( nounit )
28670  $ temp = temp/dconjg( a( kplus1, j ) )
28671  END IF
28672  x( j ) = temp
28673  110 CONTINUE
28674  ELSE
28675  jx = kx
28676  DO 140, j = 1, n
28677  temp = x( jx )
28678  ix = kx
28679  l = kplus1 - j
28680  IF( noconj )THEN
28681  DO 120, i = max( 1, j - k ), j - 1
28682  temp = temp - a( l + i, j )*x( ix )
28683  ix = ix + incx
28684  120 CONTINUE
28685  IF( nounit )
28686  $ temp = temp/a( kplus1, j )
28687  ELSE
28688  DO 130, i = max( 1, j - k ), j - 1
28689  temp = temp - dconjg( a( l + i, j ) )*x( ix )
28690  ix = ix + incx
28691  130 CONTINUE
28692  IF( nounit )
28693  $ temp = temp/dconjg( a( kplus1, j ) )
28694  END IF
28695  x( jx ) = temp
28696  jx = jx + incx
28697  IF( j.GT.k )
28698  $ kx = kx + incx
28699  140 CONTINUE
28700  END IF
28701  ELSE
28702  IF( incx.EQ.1 )THEN
28703  DO 170, j = n, 1, -1
28704  temp = x( j )
28705  l = 1 - j
28706  IF( noconj )THEN
28707  DO 150, i = min( n, j + k ), j + 1, -1
28708  temp = temp - a( l + i, j )*x( i )
28709  150 CONTINUE
28710  IF( nounit )
28711  $ temp = temp/a( 1, j )
28712  ELSE
28713  DO 160, i = min( n, j + k ), j + 1, -1
28714  temp = temp - dconjg( a( l + i, j ) )*x( i )
28715  160 CONTINUE
28716  IF( nounit )
28717  $ temp = temp/dconjg( a( 1, j ) )
28718  END IF
28719  x( j ) = temp
28720  170 CONTINUE
28721  ELSE
28722  kx = kx + ( n - 1 )*incx
28723  jx = kx
28724  DO 200, j = n, 1, -1
28725  temp = x( jx )
28726  ix = kx
28727  l = 1 - j
28728  IF( noconj )THEN
28729  DO 180, i = min( n, j + k ), j + 1, -1
28730  temp = temp - a( l + i, j )*x( ix )
28731  ix = ix - incx
28732  180 CONTINUE
28733  IF( nounit )
28734  $ temp = temp/a( 1, j )
28735  ELSE
28736  DO 190, i = min( n, j + k ), j + 1, -1
28737  temp = temp - dconjg( a( l + i, j ) )*x( ix )
28738  ix = ix - incx
28739  190 CONTINUE
28740  IF( nounit )
28741  $ temp = temp/dconjg( a( 1, j ) )
28742  END IF
28743  x( jx ) = temp
28744  jx = jx - incx
28745  IF( ( n - j ).GE.k )
28746  $ kx = kx - incx
28747  200 CONTINUE
28748  END IF
28749  END IF
28750  END IF
28751 *
28752  RETURN
28753 *
28754 * End of ZTBSV .
28755 *
28756  END
28757  SUBROUTINE ztpmv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
28758 * .. Scalar Arguments ..
28759  INTEGER INCX, N
28760  CHARACTER*1 DIAG, TRANS, UPLO
28761 * .. Array Arguments ..
28762  COMPLEX*16 AP( * ), X( * )
28763 * ..
28764 *
28765 * Purpose
28766 * =======
28767 *
28768 * ZTPMV performs one of the matrix-vector operations
28769 *
28770 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
28771 *
28772 * where x is an n element vector and A is an n by n unit, or non-unit,
28773 * upper or lower triangular matrix, supplied in packed form.
28774 *
28775 * Parameters
28776 * ==========
28777 *
28778 * UPLO - CHARACTER*1.
28779 * On entry, UPLO specifies whether the matrix is an upper or
28780 * lower triangular matrix as follows:
28781 *
28782 * UPLO = 'U' or 'u' A is an upper triangular matrix.
28783 *
28784 * UPLO = 'L' or 'l' A is a lower triangular matrix.
28785 *
28786 * Unchanged on exit.
28787 *
28788 * TRANS - CHARACTER*1.
28789 * On entry, TRANS specifies the operation to be performed as
28790 * follows:
28791 *
28792 * TRANS = 'N' or 'n' x := A*x.
28793 *
28794 * TRANS = 'T' or 't' x := A'*x.
28795 *
28796 * TRANS = 'C' or 'c' x := conjg( A' )*x.
28797 *
28798 * Unchanged on exit.
28799 *
28800 * DIAG - CHARACTER*1.
28801 * On entry, DIAG specifies whether or not A is unit
28802 * triangular as follows:
28803 *
28804 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
28805 *
28806 * DIAG = 'N' or 'n' A is not assumed to be unit
28807 * triangular.
28808 *
28809 * Unchanged on exit.
28810 *
28811 * N - INTEGER.
28812 * On entry, N specifies the order of the matrix A.
28813 * N must be at least zero.
28814 * Unchanged on exit.
28815 *
28816 * AP - COMPLEX*16 array of DIMENSION at least
28817 * ( ( n*( n + 1 ) )/2 ).
28818 * Before entry with UPLO = 'U' or 'u', the array AP must
28819 * contain the upper triangular matrix packed sequentially,
28820 * column by column, so that AP( 1 ) contains a( 1, 1 ),
28821 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
28822 * respectively, and so on.
28823 * Before entry with UPLO = 'L' or 'l', the array AP must
28824 * contain the lower triangular matrix packed sequentially,
28825 * column by column, so that AP( 1 ) contains a( 1, 1 ),
28826 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
28827 * respectively, and so on.
28828 * Note that when DIAG = 'U' or 'u', the diagonal elements of
28829 * A are not referenced, but are assumed to be unity.
28830 * Unchanged on exit.
28831 *
28832 * X - COMPLEX*16 array of dimension at least
28833 * ( 1 + ( n - 1 )*abs( INCX ) ).
28834 * Before entry, the incremented array X must contain the n
28835 * element vector x. On exit, X is overwritten with the
28836 * tranformed vector x.
28837 *
28838 * INCX - INTEGER.
28839 * On entry, INCX specifies the increment for the elements of
28840 * X. INCX must not be zero.
28841 * Unchanged on exit.
28842 *
28843 *
28844 * Level 2 Blas routine.
28845 *
28846 * -- Written on 22-October-1986.
28847 * Jack Dongarra, Argonne National Lab.
28848 * Jeremy Du Croz, Nag Central Office.
28849 * Sven Hammarling, Nag Central Office.
28850 * Richard Hanson, Sandia National Labs.
28851 *
28852 *
28853 * .. Parameters ..
28854  COMPLEX*16 ZERO
28855  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
28856 * .. Local Scalars ..
28857  COMPLEX*16 TEMP
28858  INTEGER I, INFO, IX, J, JX, K, KK, KX
28859  LOGICAL NOCONJ, NOUNIT
28860 * .. External Functions ..
28861  LOGICAL LSAME
28862  EXTERNAL lsame
28863 * .. External Subroutines ..
28864  EXTERNAL xerbla
28865 * .. Intrinsic Functions ..
28866  INTRINSIC dconjg
28867 * ..
28868 * .. Executable Statements ..
28869 *
28870 * Test the input parameters.
28871 *
28872  info = 0
28873  IF ( .NOT.lsame( uplo , 'U' ).AND.
28874  $ .NOT.lsame( uplo , 'L' ) )THEN
28875  info = 1
28876  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
28877  $ .NOT.lsame( trans, 'T' ).AND.
28878  $ .NOT.lsame( trans, 'C' ) )THEN
28879  info = 2
28880  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
28881  $ .NOT.lsame( diag , 'N' ) )THEN
28882  info = 3
28883  ELSE IF( n.LT.0 )THEN
28884  info = 4
28885  ELSE IF( incx.EQ.0 )THEN
28886  info = 7
28887  END IF
28888  IF( info.NE.0 )THEN
28889  CALL xerbla( 'ZTPMV ', info )
28890  RETURN
28891  END IF
28892 *
28893 * Quick return if possible.
28894 *
28895  IF( n.EQ.0 )
28896  $ RETURN
28897 *
28898  noconj = lsame( trans, 'T' )
28899  nounit = lsame( diag , 'N' )
28900 *
28901 * Set up the start point in X if the increment is not unity. This
28902 * will be ( N - 1 )*INCX too small for descending loops.
28903 *
28904  IF( incx.LE.0 )THEN
28905  kx = 1 - ( n - 1 )*incx
28906  ELSE IF( incx.NE.1 )THEN
28907  kx = 1
28908  END IF
28909 *
28910 * Start the operations. In this version the elements of AP are
28911 * accessed sequentially with one pass through AP.
28912 *
28913  IF( lsame( trans, 'N' ) )THEN
28914 *
28915 * Form x:= A*x.
28916 *
28917  IF( lsame( uplo, 'U' ) )THEN
28918  kk = 1
28919  IF( incx.EQ.1 )THEN
28920  DO 20, j = 1, n
28921  IF( x( j ).NE.zero )THEN
28922  temp = x( j )
28923  k = kk
28924  DO 10, i = 1, j - 1
28925  x( i ) = x( i ) + temp*ap( k )
28926  k = k + 1
28927  10 CONTINUE
28928  IF( nounit )
28929  $ x( j ) = x( j )*ap( kk + j - 1 )
28930  END IF
28931  kk = kk + j
28932  20 CONTINUE
28933  ELSE
28934  jx = kx
28935  DO 40, j = 1, n
28936  IF( x( jx ).NE.zero )THEN
28937  temp = x( jx )
28938  ix = kx
28939  DO 30, k = kk, kk + j - 2
28940  x( ix ) = x( ix ) + temp*ap( k )
28941  ix = ix + incx
28942  30 CONTINUE
28943  IF( nounit )
28944  $ x( jx ) = x( jx )*ap( kk + j - 1 )
28945  END IF
28946  jx = jx + incx
28947  kk = kk + j
28948  40 CONTINUE
28949  END IF
28950  ELSE
28951  kk = ( n*( n + 1 ) )/2
28952  IF( incx.EQ.1 )THEN
28953  DO 60, j = n, 1, -1
28954  IF( x( j ).NE.zero )THEN
28955  temp = x( j )
28956  k = kk
28957  DO 50, i = n, j + 1, -1
28958  x( i ) = x( i ) + temp*ap( k )
28959  k = k - 1
28960  50 CONTINUE
28961  IF( nounit )
28962  $ x( j ) = x( j )*ap( kk - n + j )
28963  END IF
28964  kk = kk - ( n - j + 1 )
28965  60 CONTINUE
28966  ELSE
28967  kx = kx + ( n - 1 )*incx
28968  jx = kx
28969  DO 80, j = n, 1, -1
28970  IF( x( jx ).NE.zero )THEN
28971  temp = x( jx )
28972  ix = kx
28973  DO 70, k = kk, kk - ( n - ( j + 1 ) ), -1
28974  x( ix ) = x( ix ) + temp*ap( k )
28975  ix = ix - incx
28976  70 CONTINUE
28977  IF( nounit )
28978  $ x( jx ) = x( jx )*ap( kk - n + j )
28979  END IF
28980  jx = jx - incx
28981  kk = kk - ( n - j + 1 )
28982  80 CONTINUE
28983  END IF
28984  END IF
28985  ELSE
28986 *
28987 * Form x := A'*x or x := conjg( A' )*x.
28988 *
28989  IF( lsame( uplo, 'U' ) )THEN
28990  kk = ( n*( n + 1 ) )/2
28991  IF( incx.EQ.1 )THEN
28992  DO 110, j = n, 1, -1
28993  temp = x( j )
28994  k = kk - 1
28995  IF( noconj )THEN
28996  IF( nounit )
28997  $ temp = temp*ap( kk )
28998  DO 90, i = j - 1, 1, -1
28999  temp = temp + ap( k )*x( i )
29000  k = k - 1
29001  90 CONTINUE
29002  ELSE
29003  IF( nounit )
29004  $ temp = temp*dconjg( ap( kk ) )
29005  DO 100, i = j - 1, 1, -1
29006  temp = temp + dconjg( ap( k ) )*x( i )
29007  k = k - 1
29008  100 CONTINUE
29009  END IF
29010  x( j ) = temp
29011  kk = kk - j
29012  110 CONTINUE
29013  ELSE
29014  jx = kx + ( n - 1 )*incx
29015  DO 140, j = n, 1, -1
29016  temp = x( jx )
29017  ix = jx
29018  IF( noconj )THEN
29019  IF( nounit )
29020  $ temp = temp*ap( kk )
29021  DO 120, k = kk - 1, kk - j + 1, -1
29022  ix = ix - incx
29023  temp = temp + ap( k )*x( ix )
29024  120 CONTINUE
29025  ELSE
29026  IF( nounit )
29027  $ temp = temp*dconjg( ap( kk ) )
29028  DO 130, k = kk - 1, kk - j + 1, -1
29029  ix = ix - incx
29030  temp = temp + dconjg( ap( k ) )*x( ix )
29031  130 CONTINUE
29032  END IF
29033  x( jx ) = temp
29034  jx = jx - incx
29035  kk = kk - j
29036  140 CONTINUE
29037  END IF
29038  ELSE
29039  kk = 1
29040  IF( incx.EQ.1 )THEN
29041  DO 170, j = 1, n
29042  temp = x( j )
29043  k = kk + 1
29044  IF( noconj )THEN
29045  IF( nounit )
29046  $ temp = temp*ap( kk )
29047  DO 150, i = j + 1, n
29048  temp = temp + ap( k )*x( i )
29049  k = k + 1
29050  150 CONTINUE
29051  ELSE
29052  IF( nounit )
29053  $ temp = temp*dconjg( ap( kk ) )
29054  DO 160, i = j + 1, n
29055  temp = temp + dconjg( ap( k ) )*x( i )
29056  k = k + 1
29057  160 CONTINUE
29058  END IF
29059  x( j ) = temp
29060  kk = kk + ( n - j + 1 )
29061  170 CONTINUE
29062  ELSE
29063  jx = kx
29064  DO 200, j = 1, n
29065  temp = x( jx )
29066  ix = jx
29067  IF( noconj )THEN
29068  IF( nounit )
29069  $ temp = temp*ap( kk )
29070  DO 180, k = kk + 1, kk + n - j
29071  ix = ix + incx
29072  temp = temp + ap( k )*x( ix )
29073  180 CONTINUE
29074  ELSE
29075  IF( nounit )
29076  $ temp = temp*dconjg( ap( kk ) )
29077  DO 190, k = kk + 1, kk + n - j
29078  ix = ix + incx
29079  temp = temp + dconjg( ap( k ) )*x( ix )
29080  190 CONTINUE
29081  END IF
29082  x( jx ) = temp
29083  jx = jx + incx
29084  kk = kk + ( n - j + 1 )
29085  200 CONTINUE
29086  END IF
29087  END IF
29088  END IF
29089 *
29090  RETURN
29091 *
29092 * End of ZTPMV .
29093 *
29094  END
29095  SUBROUTINE ztpsv ( UPLO, TRANS, DIAG, N, AP, X, INCX )
29096 * .. Scalar Arguments ..
29097  INTEGER INCX, N
29098  CHARACTER*1 DIAG, TRANS, UPLO
29099 * .. Array Arguments ..
29100  COMPLEX*16 AP( * ), X( * )
29101 * ..
29102 *
29103 * Purpose
29104 * =======
29105 *
29106 * ZTPSV solves one of the systems of equations
29107 *
29108 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
29109 *
29110 * where b and x are n element vectors and A is an n by n unit, or
29111 * non-unit, upper or lower triangular matrix, supplied in packed form.
29112 *
29113 * No test for singularity or near-singularity is included in this
29114 * routine. Such tests must be performed before calling this routine.
29115 *
29116 * Parameters
29117 * ==========
29118 *
29119 * UPLO - CHARACTER*1.
29120 * On entry, UPLO specifies whether the matrix is an upper or
29121 * lower triangular matrix as follows:
29122 *
29123 * UPLO = 'U' or 'u' A is an upper triangular matrix.
29124 *
29125 * UPLO = 'L' or 'l' A is a lower triangular matrix.
29126 *
29127 * Unchanged on exit.
29128 *
29129 * TRANS - CHARACTER*1.
29130 * On entry, TRANS specifies the equations to be solved as
29131 * follows:
29132 *
29133 * TRANS = 'N' or 'n' A*x = b.
29134 *
29135 * TRANS = 'T' or 't' A'*x = b.
29136 *
29137 * TRANS = 'C' or 'c' conjg( A' )*x = b.
29138 *
29139 * Unchanged on exit.
29140 *
29141 * DIAG - CHARACTER*1.
29142 * On entry, DIAG specifies whether or not A is unit
29143 * triangular as follows:
29144 *
29145 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
29146 *
29147 * DIAG = 'N' or 'n' A is not assumed to be unit
29148 * triangular.
29149 *
29150 * Unchanged on exit.
29151 *
29152 * N - INTEGER.
29153 * On entry, N specifies the order of the matrix A.
29154 * N must be at least zero.
29155 * Unchanged on exit.
29156 *
29157 * AP - COMPLEX*16 array of DIMENSION at least
29158 * ( ( n*( n + 1 ) )/2 ).
29159 * Before entry with UPLO = 'U' or 'u', the array AP must
29160 * contain the upper triangular matrix packed sequentially,
29161 * column by column, so that AP( 1 ) contains a( 1, 1 ),
29162 * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
29163 * respectively, and so on.
29164 * Before entry with UPLO = 'L' or 'l', the array AP must
29165 * contain the lower triangular matrix packed sequentially,
29166 * column by column, so that AP( 1 ) contains a( 1, 1 ),
29167 * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
29168 * respectively, and so on.
29169 * Note that when DIAG = 'U' or 'u', the diagonal elements of
29170 * A are not referenced, but are assumed to be unity.
29171 * Unchanged on exit.
29172 *
29173 * X - COMPLEX*16 array of dimension at least
29174 * ( 1 + ( n - 1 )*abs( INCX ) ).
29175 * Before entry, the incremented array X must contain the n
29176 * element right-hand side vector b. On exit, X is overwritten
29177 * with the solution vector x.
29178 *
29179 * INCX - INTEGER.
29180 * On entry, INCX specifies the increment for the elements of
29181 * X. INCX must not be zero.
29182 * Unchanged on exit.
29183 *
29184 *
29185 * Level 2 Blas routine.
29186 *
29187 * -- Written on 22-October-1986.
29188 * Jack Dongarra, Argonne National Lab.
29189 * Jeremy Du Croz, Nag Central Office.
29190 * Sven Hammarling, Nag Central Office.
29191 * Richard Hanson, Sandia National Labs.
29192 *
29193 *
29194 * .. Parameters ..
29195  COMPLEX*16 ZERO
29196  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
29197 * .. Local Scalars ..
29198  COMPLEX*16 TEMP
29199  INTEGER I, INFO, IX, J, JX, K, KK, KX
29200  LOGICAL NOCONJ, NOUNIT
29201 * .. External Functions ..
29202  LOGICAL LSAME
29203  EXTERNAL lsame
29204 * .. External Subroutines ..
29205  EXTERNAL xerbla
29206 * .. Intrinsic Functions ..
29207  INTRINSIC dconjg
29208 * ..
29209 * .. Executable Statements ..
29210 *
29211 * Test the input parameters.
29212 *
29213  info = 0
29214  IF ( .NOT.lsame( uplo , 'U' ).AND.
29215  $ .NOT.lsame( uplo , 'L' ) )THEN
29216  info = 1
29217  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
29218  $ .NOT.lsame( trans, 'T' ).AND.
29219  $ .NOT.lsame( trans, 'C' ) )THEN
29220  info = 2
29221  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
29222  $ .NOT.lsame( diag , 'N' ) )THEN
29223  info = 3
29224  ELSE IF( n.LT.0 )THEN
29225  info = 4
29226  ELSE IF( incx.EQ.0 )THEN
29227  info = 7
29228  END IF
29229  IF( info.NE.0 )THEN
29230  CALL xerbla( 'ZTPSV ', info )
29231  RETURN
29232  END IF
29233 *
29234 * Quick return if possible.
29235 *
29236  IF( n.EQ.0 )
29237  $ RETURN
29238 *
29239  noconj = lsame( trans, 'T' )
29240  nounit = lsame( diag , 'N' )
29241 *
29242 * Set up the start point in X if the increment is not unity. This
29243 * will be ( N - 1 )*INCX too small for descending loops.
29244 *
29245  IF( incx.LE.0 )THEN
29246  kx = 1 - ( n - 1 )*incx
29247  ELSE IF( incx.NE.1 )THEN
29248  kx = 1
29249  END IF
29250 *
29251 * Start the operations. In this version the elements of AP are
29252 * accessed sequentially with one pass through AP.
29253 *
29254  IF( lsame( trans, 'N' ) )THEN
29255 *
29256 * Form x := inv( A )*x.
29257 *
29258  IF( lsame( uplo, 'U' ) )THEN
29259  kk = ( n*( n + 1 ) )/2
29260  IF( incx.EQ.1 )THEN
29261  DO 20, j = n, 1, -1
29262  IF( x( j ).NE.zero )THEN
29263  IF( nounit )
29264  $ x( j ) = x( j )/ap( kk )
29265  temp = x( j )
29266  k = kk - 1
29267  DO 10, i = j - 1, 1, -1
29268  x( i ) = x( i ) - temp*ap( k )
29269  k = k - 1
29270  10 CONTINUE
29271  END IF
29272  kk = kk - j
29273  20 CONTINUE
29274  ELSE
29275  jx = kx + ( n - 1 )*incx
29276  DO 40, j = n, 1, -1
29277  IF( x( jx ).NE.zero )THEN
29278  IF( nounit )
29279  $ x( jx ) = x( jx )/ap( kk )
29280  temp = x( jx )
29281  ix = jx
29282  DO 30, k = kk - 1, kk - j + 1, -1
29283  ix = ix - incx
29284  x( ix ) = x( ix ) - temp*ap( k )
29285  30 CONTINUE
29286  END IF
29287  jx = jx - incx
29288  kk = kk - j
29289  40 CONTINUE
29290  END IF
29291  ELSE
29292  kk = 1
29293  IF( incx.EQ.1 )THEN
29294  DO 60, j = 1, n
29295  IF( x( j ).NE.zero )THEN
29296  IF( nounit )
29297  $ x( j ) = x( j )/ap( kk )
29298  temp = x( j )
29299  k = kk + 1
29300  DO 50, i = j + 1, n
29301  x( i ) = x( i ) - temp*ap( k )
29302  k = k + 1
29303  50 CONTINUE
29304  END IF
29305  kk = kk + ( n - j + 1 )
29306  60 CONTINUE
29307  ELSE
29308  jx = kx
29309  DO 80, j = 1, n
29310  IF( x( jx ).NE.zero )THEN
29311  IF( nounit )
29312  $ x( jx ) = x( jx )/ap( kk )
29313  temp = x( jx )
29314  ix = jx
29315  DO 70, k = kk + 1, kk + n - j
29316  ix = ix + incx
29317  x( ix ) = x( ix ) - temp*ap( k )
29318  70 CONTINUE
29319  END IF
29320  jx = jx + incx
29321  kk = kk + ( n - j + 1 )
29322  80 CONTINUE
29323  END IF
29324  END IF
29325  ELSE
29326 *
29327 * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x.
29328 *
29329  IF( lsame( uplo, 'U' ) )THEN
29330  kk = 1
29331  IF( incx.EQ.1 )THEN
29332  DO 110, j = 1, n
29333  temp = x( j )
29334  k = kk
29335  IF( noconj )THEN
29336  DO 90, i = 1, j - 1
29337  temp = temp - ap( k )*x( i )
29338  k = k + 1
29339  90 CONTINUE
29340  IF( nounit )
29341  $ temp = temp/ap( kk + j - 1 )
29342  ELSE
29343  DO 100, i = 1, j - 1
29344  temp = temp - dconjg( ap( k ) )*x( i )
29345  k = k + 1
29346  100 CONTINUE
29347  IF( nounit )
29348  $ temp = temp/dconjg( ap( kk + j - 1 ) )
29349  END IF
29350  x( j ) = temp
29351  kk = kk + j
29352  110 CONTINUE
29353  ELSE
29354  jx = kx
29355  DO 140, j = 1, n
29356  temp = x( jx )
29357  ix = kx
29358  IF( noconj )THEN
29359  DO 120, k = kk, kk + j - 2
29360  temp = temp - ap( k )*x( ix )
29361  ix = ix + incx
29362  120 CONTINUE
29363  IF( nounit )
29364  $ temp = temp/ap( kk + j - 1 )
29365  ELSE
29366  DO 130, k = kk, kk + j - 2
29367  temp = temp - dconjg( ap( k ) )*x( ix )
29368  ix = ix + incx
29369  130 CONTINUE
29370  IF( nounit )
29371  $ temp = temp/dconjg( ap( kk + j - 1 ) )
29372  END IF
29373  x( jx ) = temp
29374  jx = jx + incx
29375  kk = kk + j
29376  140 CONTINUE
29377  END IF
29378  ELSE
29379  kk = ( n*( n + 1 ) )/2
29380  IF( incx.EQ.1 )THEN
29381  DO 170, j = n, 1, -1
29382  temp = x( j )
29383  k = kk
29384  IF( noconj )THEN
29385  DO 150, i = n, j + 1, -1
29386  temp = temp - ap( k )*x( i )
29387  k = k - 1
29388  150 CONTINUE
29389  IF( nounit )
29390  $ temp = temp/ap( kk - n + j )
29391  ELSE
29392  DO 160, i = n, j + 1, -1
29393  temp = temp - dconjg( ap( k ) )*x( i )
29394  k = k - 1
29395  160 CONTINUE
29396  IF( nounit )
29397  $ temp = temp/dconjg( ap( kk - n + j ) )
29398  END IF
29399  x( j ) = temp
29400  kk = kk - ( n - j + 1 )
29401  170 CONTINUE
29402  ELSE
29403  kx = kx + ( n - 1 )*incx
29404  jx = kx
29405  DO 200, j = n, 1, -1
29406  temp = x( jx )
29407  ix = kx
29408  IF( noconj )THEN
29409  DO 180, k = kk, kk - ( n - ( j + 1 ) ), -1
29410  temp = temp - ap( k )*x( ix )
29411  ix = ix - incx
29412  180 CONTINUE
29413  IF( nounit )
29414  $ temp = temp/ap( kk - n + j )
29415  ELSE
29416  DO 190, k = kk, kk - ( n - ( j + 1 ) ), -1
29417  temp = temp - dconjg( ap( k ) )*x( ix )
29418  ix = ix - incx
29419  190 CONTINUE
29420  IF( nounit )
29421  $ temp = temp/dconjg( ap( kk - n + j ) )
29422  END IF
29423  x( jx ) = temp
29424  jx = jx - incx
29425  kk = kk - ( n - j + 1 )
29426  200 CONTINUE
29427  END IF
29428  END IF
29429  END IF
29430 *
29431  RETURN
29432 *
29433 * End of ZTPSV .
29434 *
29435  END
29436  SUBROUTINE ztrmm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
29437  $ b, ldb )
29438 * .. Scalar Arguments ..
29439  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
29440  INTEGER M, N, LDA, LDB
29441  COMPLEX*16 ALPHA
29442 * .. Array Arguments ..
29443  COMPLEX*16 A( lda, * ), B( ldb, * )
29444 * ..
29445 *
29446 * Purpose
29447 * =======
29448 *
29449 * ZTRMM performs one of the matrix-matrix operations
29450 *
29451 * B := alpha*op( A )*B, or B := alpha*B*op( A )
29452 *
29453 * where alpha is a scalar, B is an m by n matrix, A is a unit, or
29454 * non-unit, upper or lower triangular matrix and op( A ) is one of
29455 *
29456 * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
29457 *
29458 * Parameters
29459 * ==========
29460 *
29461 * SIDE - CHARACTER*1.
29462 * On entry, SIDE specifies whether op( A ) multiplies B from
29463 * the left or right as follows:
29464 *
29465 * SIDE = 'L' or 'l' B := alpha*op( A )*B.
29466 *
29467 * SIDE = 'R' or 'r' B := alpha*B*op( A ).
29468 *
29469 * Unchanged on exit.
29470 *
29471 * UPLO - CHARACTER*1.
29472 * On entry, UPLO specifies whether the matrix A is an upper or
29473 * lower triangular matrix as follows:
29474 *
29475 * UPLO = 'U' or 'u' A is an upper triangular matrix.
29476 *
29477 * UPLO = 'L' or 'l' A is a lower triangular matrix.
29478 *
29479 * Unchanged on exit.
29480 *
29481 * TRANSA - CHARACTER*1.
29482 * On entry, TRANSA specifies the form of op( A ) to be used in
29483 * the matrix multiplication as follows:
29484 *
29485 * TRANSA = 'N' or 'n' op( A ) = A.
29486 *
29487 * TRANSA = 'T' or 't' op( A ) = A'.
29488 *
29489 * TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
29490 *
29491 * Unchanged on exit.
29492 *
29493 * DIAG - CHARACTER*1.
29494 * On entry, DIAG specifies whether or not A is unit triangular
29495 * as follows:
29496 *
29497 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
29498 *
29499 * DIAG = 'N' or 'n' A is not assumed to be unit
29500 * triangular.
29501 *
29502 * Unchanged on exit.
29503 *
29504 * M - INTEGER.
29505 * On entry, M specifies the number of rows of B. M must be at
29506 * least zero.
29507 * Unchanged on exit.
29508 *
29509 * N - INTEGER.
29510 * On entry, N specifies the number of columns of B. N must be
29511 * at least zero.
29512 * Unchanged on exit.
29513 *
29514 * ALPHA - COMPLEX*16 .
29515 * On entry, ALPHA specifies the scalar alpha. When alpha is
29516 * zero then A is not referenced and B need not be set before
29517 * entry.
29518 * Unchanged on exit.
29519 *
29520 * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m
29521 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
29522 * Before entry with UPLO = 'U' or 'u', the leading k by k
29523 * upper triangular part of the array A must contain the upper
29524 * triangular matrix and the strictly lower triangular part of
29525 * A is not referenced.
29526 * Before entry with UPLO = 'L' or 'l', the leading k by k
29527 * lower triangular part of the array A must contain the lower
29528 * triangular matrix and the strictly upper triangular part of
29529 * A is not referenced.
29530 * Note that when DIAG = 'U' or 'u', the diagonal elements of
29531 * A are not referenced either, but are assumed to be unity.
29532 * Unchanged on exit.
29533 *
29534 * LDA - INTEGER.
29535 * On entry, LDA specifies the first dimension of A as declared
29536 * in the calling (sub) program. When SIDE = 'L' or 'l' then
29537 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
29538 * then LDA must be at least max( 1, n ).
29539 * Unchanged on exit.
29540 *
29541 * B - COMPLEX*16 array of DIMENSION ( LDB, n ).
29542 * Before entry, the leading m by n part of the array B must
29543 * contain the matrix B, and on exit is overwritten by the
29544 * transformed matrix.
29545 *
29546 * LDB - INTEGER.
29547 * On entry, LDB specifies the first dimension of B as declared
29548 * in the calling (sub) program. LDB must be at least
29549 * max( 1, m ).
29550 * Unchanged on exit.
29551 *
29552 *
29553 * Level 3 Blas routine.
29554 *
29555 * -- Written on 8-February-1989.
29556 * Jack Dongarra, Argonne National Laboratory.
29557 * Iain Duff, AERE Harwell.
29558 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
29559 * Sven Hammarling, Numerical Algorithms Group Ltd.
29560 *
29561 *
29562 * .. External Functions ..
29563  LOGICAL LSAME
29564  EXTERNAL lsame
29565 * .. External Subroutines ..
29566  EXTERNAL xerbla
29567 * .. Intrinsic Functions ..
29568  INTRINSIC dconjg, max
29569 * .. Local Scalars ..
29570  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
29571  INTEGER I, INFO, J, K, NROWA
29572  COMPLEX*16 TEMP
29573 * .. Parameters ..
29574  COMPLEX*16 ONE
29575  parameter( one = ( 1.0d+0, 0.0d+0 ) )
29576  COMPLEX*16 ZERO
29577  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
29578 * ..
29579 * .. Executable Statements ..
29580 *
29581 * Test the input parameters.
29582 *
29583  lside = lsame( side , 'L' )
29584  IF( lside )THEN
29585  nrowa = m
29586  ELSE
29587  nrowa = n
29588  END IF
29589  noconj = lsame( transa, 'T' )
29590  nounit = lsame( diag , 'N' )
29591  upper = lsame( uplo , 'U' )
29592 *
29593  info = 0
29594  IF( ( .NOT.lside ).AND.
29595  $ ( .NOT.lsame( side , 'R' ) ) )THEN
29596  info = 1
29597  ELSE IF( ( .NOT.upper ).AND.
29598  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
29599  info = 2
29600  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
29601  $ ( .NOT.lsame( transa, 'T' ) ).AND.
29602  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
29603  info = 3
29604  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
29605  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
29606  info = 4
29607  ELSE IF( m .LT.0 )THEN
29608  info = 5
29609  ELSE IF( n .LT.0 )THEN
29610  info = 6
29611  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
29612  info = 9
29613  ELSE IF( ldb.LT.max( 1, m ) )THEN
29614  info = 11
29615  END IF
29616  IF( info.NE.0 )THEN
29617  CALL xerbla( 'ZTRMM ', info )
29618  RETURN
29619  END IF
29620 *
29621 * Quick return if possible.
29622 *
29623  IF( n.EQ.0 )
29624  $ RETURN
29625 *
29626 * And when alpha.eq.zero.
29627 *
29628  IF( alpha.EQ.zero )THEN
29629  DO 20, j = 1, n
29630  DO 10, i = 1, m
29631  b( i, j ) = zero
29632  10 CONTINUE
29633  20 CONTINUE
29634  RETURN
29635  END IF
29636 *
29637 * Start the operations.
29638 *
29639  IF( lside )THEN
29640  IF( lsame( transa, 'N' ) )THEN
29641 *
29642 * Form B := alpha*A*B.
29643 *
29644  IF( upper )THEN
29645  DO 50, j = 1, n
29646  DO 40, k = 1, m
29647  IF( b( k, j ).NE.zero )THEN
29648  temp = alpha*b( k, j )
29649  DO 30, i = 1, k - 1
29650  b( i, j ) = b( i, j ) + temp*a( i, k )
29651  30 CONTINUE
29652  IF( nounit )
29653  $ temp = temp*a( k, k )
29654  b( k, j ) = temp
29655  END IF
29656  40 CONTINUE
29657  50 CONTINUE
29658  ELSE
29659  DO 80, j = 1, n
29660  DO 70 k = m, 1, -1
29661  IF( b( k, j ).NE.zero )THEN
29662  temp = alpha*b( k, j )
29663  b( k, j ) = temp
29664  IF( nounit )
29665  $ b( k, j ) = b( k, j )*a( k, k )
29666  DO 60, i = k + 1, m
29667  b( i, j ) = b( i, j ) + temp*a( i, k )
29668  60 CONTINUE
29669  END IF
29670  70 CONTINUE
29671  80 CONTINUE
29672  END IF
29673  ELSE
29674 *
29675 * Form B := alpha*A'*B or B := alpha*conjg( A' )*B.
29676 *
29677  IF( upper )THEN
29678  DO 120, j = 1, n
29679  DO 110, i = m, 1, -1
29680  temp = b( i, j )
29681  IF( noconj )THEN
29682  IF( nounit )
29683  $ temp = temp*a( i, i )
29684  DO 90, k = 1, i - 1
29685  temp = temp + a( k, i )*b( k, j )
29686  90 CONTINUE
29687  ELSE
29688  IF( nounit )
29689  $ temp = temp*dconjg( a( i, i ) )
29690  DO 100, k = 1, i - 1
29691  temp = temp + dconjg( a( k, i ) )*b( k, j )
29692  100 CONTINUE
29693  END IF
29694  b( i, j ) = alpha*temp
29695  110 CONTINUE
29696  120 CONTINUE
29697  ELSE
29698  DO 160, j = 1, n
29699  DO 150, i = 1, m
29700  temp = b( i, j )
29701  IF( noconj )THEN
29702  IF( nounit )
29703  $ temp = temp*a( i, i )
29704  DO 130, k = i + 1, m
29705  temp = temp + a( k, i )*b( k, j )
29706  130 CONTINUE
29707  ELSE
29708  IF( nounit )
29709  $ temp = temp*dconjg( a( i, i ) )
29710  DO 140, k = i + 1, m
29711  temp = temp + dconjg( a( k, i ) )*b( k, j )
29712  140 CONTINUE
29713  END IF
29714  b( i, j ) = alpha*temp
29715  150 CONTINUE
29716  160 CONTINUE
29717  END IF
29718  END IF
29719  ELSE
29720  IF( lsame( transa, 'N' ) )THEN
29721 *
29722 * Form B := alpha*B*A.
29723 *
29724  IF( upper )THEN
29725  DO 200, j = n, 1, -1
29726  temp = alpha
29727  IF( nounit )
29728  $ temp = temp*a( j, j )
29729  DO 170, i = 1, m
29730  b( i, j ) = temp*b( i, j )
29731  170 CONTINUE
29732  DO 190, k = 1, j - 1
29733  IF( a( k, j ).NE.zero )THEN
29734  temp = alpha*a( k, j )
29735  DO 180, i = 1, m
29736  b( i, j ) = b( i, j ) + temp*b( i, k )
29737  180 CONTINUE
29738  END IF
29739  190 CONTINUE
29740  200 CONTINUE
29741  ELSE
29742  DO 240, j = 1, n
29743  temp = alpha
29744  IF( nounit )
29745  $ temp = temp*a( j, j )
29746  DO 210, i = 1, m
29747  b( i, j ) = temp*b( i, j )
29748  210 CONTINUE
29749  DO 230, k = j + 1, n
29750  IF( a( k, j ).NE.zero )THEN
29751  temp = alpha*a( k, j )
29752  DO 220, i = 1, m
29753  b( i, j ) = b( i, j ) + temp*b( i, k )
29754  220 CONTINUE
29755  END IF
29756  230 CONTINUE
29757  240 CONTINUE
29758  END IF
29759  ELSE
29760 *
29761 * Form B := alpha*B*A' or B := alpha*B*conjg( A' ).
29762 *
29763  IF( upper )THEN
29764  DO 280, k = 1, n
29765  DO 260, j = 1, k - 1
29766  IF( a( j, k ).NE.zero )THEN
29767  IF( noconj )THEN
29768  temp = alpha*a( j, k )
29769  ELSE
29770  temp = alpha*dconjg( a( j, k ) )
29771  END IF
29772  DO 250, i = 1, m
29773  b( i, j ) = b( i, j ) + temp*b( i, k )
29774  250 CONTINUE
29775  END IF
29776  260 CONTINUE
29777  temp = alpha
29778  IF( nounit )THEN
29779  IF( noconj )THEN
29780  temp = temp*a( k, k )
29781  ELSE
29782  temp = temp*dconjg( a( k, k ) )
29783  END IF
29784  END IF
29785  IF( temp.NE.one )THEN
29786  DO 270, i = 1, m
29787  b( i, k ) = temp*b( i, k )
29788  270 CONTINUE
29789  END IF
29790  280 CONTINUE
29791  ELSE
29792  DO 320, k = n, 1, -1
29793  DO 300, j = k + 1, n
29794  IF( a( j, k ).NE.zero )THEN
29795  IF( noconj )THEN
29796  temp = alpha*a( j, k )
29797  ELSE
29798  temp = alpha*dconjg( a( j, k ) )
29799  END IF
29800  DO 290, i = 1, m
29801  b( i, j ) = b( i, j ) + temp*b( i, k )
29802  290 CONTINUE
29803  END IF
29804  300 CONTINUE
29805  temp = alpha
29806  IF( nounit )THEN
29807  IF( noconj )THEN
29808  temp = temp*a( k, k )
29809  ELSE
29810  temp = temp*dconjg( a( k, k ) )
29811  END IF
29812  END IF
29813  IF( temp.NE.one )THEN
29814  DO 310, i = 1, m
29815  b( i, k ) = temp*b( i, k )
29816  310 CONTINUE
29817  END IF
29818  320 CONTINUE
29819  END IF
29820  END IF
29821  END IF
29822 *
29823  RETURN
29824 *
29825 * End of ZTRMM .
29826 *
29827  END
29828  SUBROUTINE ztrmv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
29829 * .. Scalar Arguments ..
29830  INTEGER INCX, LDA, N
29831  CHARACTER*1 DIAG, TRANS, UPLO
29832 * .. Array Arguments ..
29833  COMPLEX*16 A( lda, * ), X( * )
29834 * ..
29835 *
29836 * Purpose
29837 * =======
29838 *
29839 * ZTRMV performs one of the matrix-vector operations
29840 *
29841 * x := A*x, or x := A'*x, or x := conjg( A' )*x,
29842 *
29843 * where x is an n element vector and A is an n by n unit, or non-unit,
29844 * upper or lower triangular matrix.
29845 *
29846 * Parameters
29847 * ==========
29848 *
29849 * UPLO - CHARACTER*1.
29850 * On entry, UPLO specifies whether the matrix is an upper or
29851 * lower triangular matrix as follows:
29852 *
29853 * UPLO = 'U' or 'u' A is an upper triangular matrix.
29854 *
29855 * UPLO = 'L' or 'l' A is a lower triangular matrix.
29856 *
29857 * Unchanged on exit.
29858 *
29859 * TRANS - CHARACTER*1.
29860 * On entry, TRANS specifies the operation to be performed as
29861 * follows:
29862 *
29863 * TRANS = 'N' or 'n' x := A*x.
29864 *
29865 * TRANS = 'T' or 't' x := A'*x.
29866 *
29867 * TRANS = 'C' or 'c' x := conjg( A' )*x.
29868 *
29869 * Unchanged on exit.
29870 *
29871 * DIAG - CHARACTER*1.
29872 * On entry, DIAG specifies whether or not A is unit
29873 * triangular as follows:
29874 *
29875 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
29876 *
29877 * DIAG = 'N' or 'n' A is not assumed to be unit
29878 * triangular.
29879 *
29880 * Unchanged on exit.
29881 *
29882 * N - INTEGER.
29883 * On entry, N specifies the order of the matrix A.
29884 * N must be at least zero.
29885 * Unchanged on exit.
29886 *
29887 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
29888 * Before entry with UPLO = 'U' or 'u', the leading n by n
29889 * upper triangular part of the array A must contain the upper
29890 * triangular matrix and the strictly lower triangular part of
29891 * A is not referenced.
29892 * Before entry with UPLO = 'L' or 'l', the leading n by n
29893 * lower triangular part of the array A must contain the lower
29894 * triangular matrix and the strictly upper triangular part of
29895 * A is not referenced.
29896 * Note that when DIAG = 'U' or 'u', the diagonal elements of
29897 * A are not referenced either, but are assumed to be unity.
29898 * Unchanged on exit.
29899 *
29900 * LDA - INTEGER.
29901 * On entry, LDA specifies the first dimension of A as declared
29902 * in the calling (sub) program. LDA must be at least
29903 * max( 1, n ).
29904 * Unchanged on exit.
29905 *
29906 * X - COMPLEX*16 array of dimension at least
29907 * ( 1 + ( n - 1 )*abs( INCX ) ).
29908 * Before entry, the incremented array X must contain the n
29909 * element vector x. On exit, X is overwritten with the
29910 * tranformed vector x.
29911 *
29912 * INCX - INTEGER.
29913 * On entry, INCX specifies the increment for the elements of
29914 * X. INCX must not be zero.
29915 * Unchanged on exit.
29916 *
29917 *
29918 * Level 2 Blas routine.
29919 *
29920 * -- Written on 22-October-1986.
29921 * Jack Dongarra, Argonne National Lab.
29922 * Jeremy Du Croz, Nag Central Office.
29923 * Sven Hammarling, Nag Central Office.
29924 * Richard Hanson, Sandia National Labs.
29925 *
29926 *
29927 * .. Parameters ..
29928  COMPLEX*16 ZERO
29929  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
29930 * .. Local Scalars ..
29931  COMPLEX*16 TEMP
29932  INTEGER I, INFO, IX, J, JX, KX
29933  LOGICAL NOCONJ, NOUNIT
29934 * .. External Functions ..
29935  LOGICAL LSAME
29936  EXTERNAL lsame
29937 * .. External Subroutines ..
29938  EXTERNAL xerbla
29939 * .. Intrinsic Functions ..
29940  INTRINSIC dconjg, max
29941 * ..
29942 * .. Executable Statements ..
29943 *
29944 * Test the input parameters.
29945 *
29946  info = 0
29947  IF ( .NOT.lsame( uplo , 'U' ).AND.
29948  $ .NOT.lsame( uplo , 'L' ) )THEN
29949  info = 1
29950  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
29951  $ .NOT.lsame( trans, 'T' ).AND.
29952  $ .NOT.lsame( trans, 'C' ) )THEN
29953  info = 2
29954  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
29955  $ .NOT.lsame( diag , 'N' ) )THEN
29956  info = 3
29957  ELSE IF( n.LT.0 )THEN
29958  info = 4
29959  ELSE IF( lda.LT.max( 1, n ) )THEN
29960  info = 6
29961  ELSE IF( incx.EQ.0 )THEN
29962  info = 8
29963  END IF
29964  IF( info.NE.0 )THEN
29965  CALL xerbla( 'ZTRMV ', info )
29966  RETURN
29967  END IF
29968 *
29969 * Quick return if possible.
29970 *
29971  IF( n.EQ.0 )
29972  $ RETURN
29973 *
29974  noconj = lsame( trans, 'T' )
29975  nounit = lsame( diag , 'N' )
29976 *
29977 * Set up the start point in X if the increment is not unity. This
29978 * will be ( N - 1 )*INCX too small for descending loops.
29979 *
29980  IF( incx.LE.0 )THEN
29981  kx = 1 - ( n - 1 )*incx
29982  ELSE IF( incx.NE.1 )THEN
29983  kx = 1
29984  END IF
29985 *
29986 * Start the operations. In this version the elements of A are
29987 * accessed sequentially with one pass through A.
29988 *
29989  IF( lsame( trans, 'N' ) )THEN
29990 *
29991 * Form x := A*x.
29992 *
29993  IF( lsame( uplo, 'U' ) )THEN
29994  IF( incx.EQ.1 )THEN
29995  DO 20, j = 1, n
29996  IF( x( j ).NE.zero )THEN
29997  temp = x( j )
29998  DO 10, i = 1, j - 1
29999  x( i ) = x( i ) + temp*a( i, j )
30000  10 CONTINUE
30001  IF( nounit )
30002  $ x( j ) = x( j )*a( j, j )
30003  END IF
30004  20 CONTINUE
30005  ELSE
30006  jx = kx
30007  DO 40, j = 1, n
30008  IF( x( jx ).NE.zero )THEN
30009  temp = x( jx )
30010  ix = kx
30011  DO 30, i = 1, j - 1
30012  x( ix ) = x( ix ) + temp*a( i, j )
30013  ix = ix + incx
30014  30 CONTINUE
30015  IF( nounit )
30016  $ x( jx ) = x( jx )*a( j, j )
30017  END IF
30018  jx = jx + incx
30019  40 CONTINUE
30020  END IF
30021  ELSE
30022  IF( incx.EQ.1 )THEN
30023  DO 60, j = n, 1, -1
30024  IF( x( j ).NE.zero )THEN
30025  temp = x( j )
30026  DO 50, i = n, j + 1, -1
30027  x( i ) = x( i ) + temp*a( i, j )
30028  50 CONTINUE
30029  IF( nounit )
30030  $ x( j ) = x( j )*a( j, j )
30031  END IF
30032  60 CONTINUE
30033  ELSE
30034  kx = kx + ( n - 1 )*incx
30035  jx = kx
30036  DO 80, j = n, 1, -1
30037  IF( x( jx ).NE.zero )THEN
30038  temp = x( jx )
30039  ix = kx
30040  DO 70, i = n, j + 1, -1
30041  x( ix ) = x( ix ) + temp*a( i, j )
30042  ix = ix - incx
30043  70 CONTINUE
30044  IF( nounit )
30045  $ x( jx ) = x( jx )*a( j, j )
30046  END IF
30047  jx = jx - incx
30048  80 CONTINUE
30049  END IF
30050  END IF
30051  ELSE
30052 *
30053 * Form x := A'*x or x := conjg( A' )*x.
30054 *
30055  IF( lsame( uplo, 'U' ) )THEN
30056  IF( incx.EQ.1 )THEN
30057  DO 110, j = n, 1, -1
30058  temp = x( j )
30059  IF( noconj )THEN
30060  IF( nounit )
30061  $ temp = temp*a( j, j )
30062  DO 90, i = j - 1, 1, -1
30063  temp = temp + a( i, j )*x( i )
30064  90 CONTINUE
30065  ELSE
30066  IF( nounit )
30067  $ temp = temp*dconjg( a( j, j ) )
30068  DO 100, i = j - 1, 1, -1
30069  temp = temp + dconjg( a( i, j ) )*x( i )
30070  100 CONTINUE
30071  END IF
30072  x( j ) = temp
30073  110 CONTINUE
30074  ELSE
30075  jx = kx + ( n - 1 )*incx
30076  DO 140, j = n, 1, -1
30077  temp = x( jx )
30078  ix = jx
30079  IF( noconj )THEN
30080  IF( nounit )
30081  $ temp = temp*a( j, j )
30082  DO 120, i = j - 1, 1, -1
30083  ix = ix - incx
30084  temp = temp + a( i, j )*x( ix )
30085  120 CONTINUE
30086  ELSE
30087  IF( nounit )
30088  $ temp = temp*dconjg( a( j, j ) )
30089  DO 130, i = j - 1, 1, -1
30090  ix = ix - incx
30091  temp = temp + dconjg( a( i, j ) )*x( ix )
30092  130 CONTINUE
30093  END IF
30094  x( jx ) = temp
30095  jx = jx - incx
30096  140 CONTINUE
30097  END IF
30098  ELSE
30099  IF( incx.EQ.1 )THEN
30100  DO 170, j = 1, n
30101  temp = x( j )
30102  IF( noconj )THEN
30103  IF( nounit )
30104  $ temp = temp*a( j, j )
30105  DO 150, i = j + 1, n
30106  temp = temp + a( i, j )*x( i )
30107  150 CONTINUE
30108  ELSE
30109  IF( nounit )
30110  $ temp = temp*dconjg( a( j, j ) )
30111  DO 160, i = j + 1, n
30112  temp = temp + dconjg( a( i, j ) )*x( i )
30113  160 CONTINUE
30114  END IF
30115  x( j ) = temp
30116  170 CONTINUE
30117  ELSE
30118  jx = kx
30119  DO 200, j = 1, n
30120  temp = x( jx )
30121  ix = jx
30122  IF( noconj )THEN
30123  IF( nounit )
30124  $ temp = temp*a( j, j )
30125  DO 180, i = j + 1, n
30126  ix = ix + incx
30127  temp = temp + a( i, j )*x( ix )
30128  180 CONTINUE
30129  ELSE
30130  IF( nounit )
30131  $ temp = temp*dconjg( a( j, j ) )
30132  DO 190, i = j + 1, n
30133  ix = ix + incx
30134  temp = temp + dconjg( a( i, j ) )*x( ix )
30135  190 CONTINUE
30136  END IF
30137  x( jx ) = temp
30138  jx = jx + incx
30139  200 CONTINUE
30140  END IF
30141  END IF
30142  END IF
30143 *
30144  RETURN
30145 *
30146 * End of ZTRMV .
30147 *
30148  END
30149  SUBROUTINE ztrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
30150  $ b, ldb )
30151 * .. Scalar Arguments ..
30152  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
30153  INTEGER M, N, LDA, LDB
30154  COMPLEX*16 ALPHA
30155 * .. Array Arguments ..
30156  COMPLEX*16 A( lda, * ), B( ldb, * )
30157 * ..
30158 *
30159 * Purpose
30160 * =======
30161 *
30162 * ZTRSM solves one of the matrix equations
30163 *
30164 * op( A )*X = alpha*B, or X*op( A ) = alpha*B,
30165 *
30166 * where alpha is a scalar, X and B are m by n matrices, A is a unit, or
30167 * non-unit, upper or lower triangular matrix and op( A ) is one of
30168 *
30169 * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
30170 *
30171 * The matrix X is overwritten on B.
30172 *
30173 * Parameters
30174 * ==========
30175 *
30176 * SIDE - CHARACTER*1.
30177 * On entry, SIDE specifies whether op( A ) appears on the left
30178 * or right of X as follows:
30179 *
30180 * SIDE = 'L' or 'l' op( A )*X = alpha*B.
30181 *
30182 * SIDE = 'R' or 'r' X*op( A ) = alpha*B.
30183 *
30184 * Unchanged on exit.
30185 *
30186 * UPLO - CHARACTER*1.
30187 * On entry, UPLO specifies whether the matrix A is an upper or
30188 * lower triangular matrix as follows:
30189 *
30190 * UPLO = 'U' or 'u' A is an upper triangular matrix.
30191 *
30192 * UPLO = 'L' or 'l' A is a lower triangular matrix.
30193 *
30194 * Unchanged on exit.
30195 *
30196 * TRANSA - CHARACTER*1.
30197 * On entry, TRANSA specifies the form of op( A ) to be used in
30198 * the matrix multiplication as follows:
30199 *
30200 * TRANSA = 'N' or 'n' op( A ) = A.
30201 *
30202 * TRANSA = 'T' or 't' op( A ) = A'.
30203 *
30204 * TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
30205 *
30206 * Unchanged on exit.
30207 *
30208 * DIAG - CHARACTER*1.
30209 * On entry, DIAG specifies whether or not A is unit triangular
30210 * as follows:
30211 *
30212 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
30213 *
30214 * DIAG = 'N' or 'n' A is not assumed to be unit
30215 * triangular.
30216 *
30217 * Unchanged on exit.
30218 *
30219 * M - INTEGER.
30220 * On entry, M specifies the number of rows of B. M must be at
30221 * least zero.
30222 * Unchanged on exit.
30223 *
30224 * N - INTEGER.
30225 * On entry, N specifies the number of columns of B. N must be
30226 * at least zero.
30227 * Unchanged on exit.
30228 *
30229 * ALPHA - COMPLEX*16 .
30230 * On entry, ALPHA specifies the scalar alpha. When alpha is
30231 * zero then A is not referenced and B need not be set before
30232 * entry.
30233 * Unchanged on exit.
30234 *
30235 * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m
30236 * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
30237 * Before entry with UPLO = 'U' or 'u', the leading k by k
30238 * upper triangular part of the array A must contain the upper
30239 * triangular matrix and the strictly lower triangular part of
30240 * A is not referenced.
30241 * Before entry with UPLO = 'L' or 'l', the leading k by k
30242 * lower triangular part of the array A must contain the lower
30243 * triangular matrix and the strictly upper triangular part of
30244 * A is not referenced.
30245 * Note that when DIAG = 'U' or 'u', the diagonal elements of
30246 * A are not referenced either, but are assumed to be unity.
30247 * Unchanged on exit.
30248 *
30249 * LDA - INTEGER.
30250 * On entry, LDA specifies the first dimension of A as declared
30251 * in the calling (sub) program. When SIDE = 'L' or 'l' then
30252 * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
30253 * then LDA must be at least max( 1, n ).
30254 * Unchanged on exit.
30255 *
30256 * B - COMPLEX*16 array of DIMENSION ( LDB, n ).
30257 * Before entry, the leading m by n part of the array B must
30258 * contain the right-hand side matrix B, and on exit is
30259 * overwritten by the solution matrix X.
30260 *
30261 * LDB - INTEGER.
30262 * On entry, LDB specifies the first dimension of B as declared
30263 * in the calling (sub) program. LDB must be at least
30264 * max( 1, m ).
30265 * Unchanged on exit.
30266 *
30267 *
30268 * Level 3 Blas routine.
30269 *
30270 * -- Written on 8-February-1989.
30271 * Jack Dongarra, Argonne National Laboratory.
30272 * Iain Duff, AERE Harwell.
30273 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
30274 * Sven Hammarling, Numerical Algorithms Group Ltd.
30275 *
30276 *
30277 * .. External Functions ..
30278  LOGICAL LSAME
30279  EXTERNAL lsame
30280 * .. External Subroutines ..
30281  EXTERNAL xerbla
30282 * .. Intrinsic Functions ..
30283  INTRINSIC dconjg, max
30284 * .. Local Scalars ..
30285  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
30286  INTEGER I, INFO, J, K, NROWA
30287  COMPLEX*16 TEMP
30288 * .. Parameters ..
30289  COMPLEX*16 ONE
30290  parameter( one = ( 1.0d+0, 0.0d+0 ) )
30291  COMPLEX*16 ZERO
30292  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
30293 * ..
30294 * .. Executable Statements ..
30295 *
30296 * Test the input parameters.
30297 *
30298  lside = lsame( side , 'L' )
30299  IF( lside )THEN
30300  nrowa = m
30301  ELSE
30302  nrowa = n
30303  END IF
30304  noconj = lsame( transa, 'T' )
30305  nounit = lsame( diag , 'N' )
30306  upper = lsame( uplo , 'U' )
30307 *
30308  info = 0
30309  IF( ( .NOT.lside ).AND.
30310  $ ( .NOT.lsame( side , 'R' ) ) )THEN
30311  info = 1
30312  ELSE IF( ( .NOT.upper ).AND.
30313  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
30314  info = 2
30315  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
30316  $ ( .NOT.lsame( transa, 'T' ) ).AND.
30317  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
30318  info = 3
30319  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
30320  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
30321  info = 4
30322  ELSE IF( m .LT.0 )THEN
30323  info = 5
30324  ELSE IF( n .LT.0 )THEN
30325  info = 6
30326  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
30327  info = 9
30328  ELSE IF( ldb.LT.max( 1, m ) )THEN
30329  info = 11
30330  END IF
30331  IF( info.NE.0 )THEN
30332  CALL xerbla( 'ZTRSM ', info )
30333  RETURN
30334  END IF
30335 *
30336 * Quick return if possible.
30337 *
30338  IF( n.EQ.0 )
30339  $ RETURN
30340 *
30341 * And when alpha.eq.zero.
30342 *
30343  IF( alpha.EQ.zero )THEN
30344  DO 20, j = 1, n
30345  DO 10, i = 1, m
30346  b( i, j ) = zero
30347  10 CONTINUE
30348  20 CONTINUE
30349  RETURN
30350  END IF
30351 *
30352 * Start the operations.
30353 *
30354  IF( lside )THEN
30355  IF( lsame( transa, 'N' ) )THEN
30356 *
30357 * Form B := alpha*inv( A )*B.
30358 *
30359  IF( upper )THEN
30360  DO 60, j = 1, n
30361  IF( alpha.NE.one )THEN
30362  DO 30, i = 1, m
30363  b( i, j ) = alpha*b( i, j )
30364  30 CONTINUE
30365  END IF
30366  DO 50, k = m, 1, -1
30367  IF( b( k, j ).NE.zero )THEN
30368  IF( nounit )
30369  $ b( k, j ) = b( k, j )/a( k, k )
30370  DO 40, i = 1, k - 1
30371  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
30372  40 CONTINUE
30373  END IF
30374  50 CONTINUE
30375  60 CONTINUE
30376  ELSE
30377  DO 100, j = 1, n
30378  IF( alpha.NE.one )THEN
30379  DO 70, i = 1, m
30380  b( i, j ) = alpha*b( i, j )
30381  70 CONTINUE
30382  END IF
30383  DO 90 k = 1, m
30384  IF( b( k, j ).NE.zero )THEN
30385  IF( nounit )
30386  $ b( k, j ) = b( k, j )/a( k, k )
30387  DO 80, i = k + 1, m
30388  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
30389  80 CONTINUE
30390  END IF
30391  90 CONTINUE
30392  100 CONTINUE
30393  END IF
30394  ELSE
30395 *
30396 * Form B := alpha*inv( A' )*B
30397 * or B := alpha*inv( conjg( A' ) )*B.
30398 *
30399  IF( upper )THEN
30400  DO 140, j = 1, n
30401  DO 130, i = 1, m
30402  temp = alpha*b( i, j )
30403  IF( noconj )THEN
30404  DO 110, k = 1, i - 1
30405  temp = temp - a( k, i )*b( k, j )
30406  110 CONTINUE
30407  IF( nounit )
30408  $ temp = temp/a( i, i )
30409  ELSE
30410  DO 120, k = 1, i - 1
30411  temp = temp - dconjg( a( k, i ) )*b( k, j )
30412  120 CONTINUE
30413  IF( nounit )
30414  $ temp = temp/dconjg( a( i, i ) )
30415  END IF
30416  b( i, j ) = temp
30417  130 CONTINUE
30418  140 CONTINUE
30419  ELSE
30420  DO 180, j = 1, n
30421  DO 170, i = m, 1, -1
30422  temp = alpha*b( i, j )
30423  IF( noconj )THEN
30424  DO 150, k = i + 1, m
30425  temp = temp - a( k, i )*b( k, j )
30426  150 CONTINUE
30427  IF( nounit )
30428  $ temp = temp/a( i, i )
30429  ELSE
30430  DO 160, k = i + 1, m
30431  temp = temp - dconjg( a( k, i ) )*b( k, j )
30432  160 CONTINUE
30433  IF( nounit )
30434  $ temp = temp/dconjg( a( i, i ) )
30435  END IF
30436  b( i, j ) = temp
30437  170 CONTINUE
30438  180 CONTINUE
30439  END IF
30440  END IF
30441  ELSE
30442  IF( lsame( transa, 'N' ) )THEN
30443 *
30444 * Form B := alpha*B*inv( A ).
30445 *
30446  IF( upper )THEN
30447  DO 230, j = 1, n
30448  IF( alpha.NE.one )THEN
30449  DO 190, i = 1, m
30450  b( i, j ) = alpha*b( i, j )
30451  190 CONTINUE
30452  END IF
30453  DO 210, k = 1, j - 1
30454  IF( a( k, j ).NE.zero )THEN
30455  DO 200, i = 1, m
30456  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
30457  200 CONTINUE
30458  END IF
30459  210 CONTINUE
30460  IF( nounit )THEN
30461  temp = one/a( j, j )
30462  DO 220, i = 1, m
30463  b( i, j ) = temp*b( i, j )
30464  220 CONTINUE
30465  END IF
30466  230 CONTINUE
30467  ELSE
30468  DO 280, j = n, 1, -1
30469  IF( alpha.NE.one )THEN
30470  DO 240, i = 1, m
30471  b( i, j ) = alpha*b( i, j )
30472  240 CONTINUE
30473  END IF
30474  DO 260, k = j + 1, n
30475  IF( a( k, j ).NE.zero )THEN
30476  DO 250, i = 1, m
30477  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
30478  250 CONTINUE
30479  END IF
30480  260 CONTINUE
30481  IF( nounit )THEN
30482  temp = one/a( j, j )
30483  DO 270, i = 1, m
30484  b( i, j ) = temp*b( i, j )
30485  270 CONTINUE
30486  END IF
30487  280 CONTINUE
30488  END IF
30489  ELSE
30490 *
30491 * Form B := alpha*B*inv( A' )
30492 * or B := alpha*B*inv( conjg( A' ) ).
30493 *
30494  IF( upper )THEN
30495  DO 330, k = n, 1, -1
30496  IF( nounit )THEN
30497  IF( noconj )THEN
30498  temp = one/a( k, k )
30499  ELSE
30500  temp = one/dconjg( a( k, k ) )
30501  END IF
30502  DO 290, i = 1, m
30503  b( i, k ) = temp*b( i, k )
30504  290 CONTINUE
30505  END IF
30506  DO 310, j = 1, k - 1
30507  IF( a( j, k ).NE.zero )THEN
30508  IF( noconj )THEN
30509  temp = a( j, k )
30510  ELSE
30511  temp = dconjg( a( j, k ) )
30512  END IF
30513  DO 300, i = 1, m
30514  b( i, j ) = b( i, j ) - temp*b( i, k )
30515  300 CONTINUE
30516  END IF
30517  310 CONTINUE
30518  IF( alpha.NE.one )THEN
30519  DO 320, i = 1, m
30520  b( i, k ) = alpha*b( i, k )
30521  320 CONTINUE
30522  END IF
30523  330 CONTINUE
30524  ELSE
30525  DO 380, k = 1, n
30526  IF( nounit )THEN
30527  IF( noconj )THEN
30528  temp = one/a( k, k )
30529  ELSE
30530  temp = one/dconjg( a( k, k ) )
30531  END IF
30532  DO 340, i = 1, m
30533  b( i, k ) = temp*b( i, k )
30534  340 CONTINUE
30535  END IF
30536  DO 360, j = k + 1, n
30537  IF( a( j, k ).NE.zero )THEN
30538  IF( noconj )THEN
30539  temp = a( j, k )
30540  ELSE
30541  temp = dconjg( a( j, k ) )
30542  END IF
30543  DO 350, i = 1, m
30544  b( i, j ) = b( i, j ) - temp*b( i, k )
30545  350 CONTINUE
30546  END IF
30547  360 CONTINUE
30548  IF( alpha.NE.one )THEN
30549  DO 370, i = 1, m
30550  b( i, k ) = alpha*b( i, k )
30551  370 CONTINUE
30552  END IF
30553  380 CONTINUE
30554  END IF
30555  END IF
30556  END IF
30557 *
30558  RETURN
30559 *
30560 * End of ZTRSM .
30561 *
30562  END
30563  SUBROUTINE ztrsv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
30564 * .. Scalar Arguments ..
30565  INTEGER INCX, LDA, N
30566  CHARACTER*1 DIAG, TRANS, UPLO
30567 * .. Array Arguments ..
30568  COMPLEX*16 A( lda, * ), X( * )
30569 * ..
30570 *
30571 * Purpose
30572 * =======
30573 *
30574 * ZTRSV solves one of the systems of equations
30575 *
30576 * A*x = b, or A'*x = b, or conjg( A' )*x = b,
30577 *
30578 * where b and x are n element vectors and A is an n by n unit, or
30579 * non-unit, upper or lower triangular matrix.
30580 *
30581 * No test for singularity or near-singularity is included in this
30582 * routine. Such tests must be performed before calling this routine.
30583 *
30584 * Parameters
30585 * ==========
30586 *
30587 * UPLO - CHARACTER*1.
30588 * On entry, UPLO specifies whether the matrix is an upper or
30589 * lower triangular matrix as follows:
30590 *
30591 * UPLO = 'U' or 'u' A is an upper triangular matrix.
30592 *
30593 * UPLO = 'L' or 'l' A is a lower triangular matrix.
30594 *
30595 * Unchanged on exit.
30596 *
30597 * TRANS - CHARACTER*1.
30598 * On entry, TRANS specifies the equations to be solved as
30599 * follows:
30600 *
30601 * TRANS = 'N' or 'n' A*x = b.
30602 *
30603 * TRANS = 'T' or 't' A'*x = b.
30604 *
30605 * TRANS = 'C' or 'c' conjg( A' )*x = b.
30606 *
30607 * Unchanged on exit.
30608 *
30609 * DIAG - CHARACTER*1.
30610 * On entry, DIAG specifies whether or not A is unit
30611 * triangular as follows:
30612 *
30613 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
30614 *
30615 * DIAG = 'N' or 'n' A is not assumed to be unit
30616 * triangular.
30617 *
30618 * Unchanged on exit.
30619 *
30620 * N - INTEGER.
30621 * On entry, N specifies the order of the matrix A.
30622 * N must be at least zero.
30623 * Unchanged on exit.
30624 *
30625 * A - COMPLEX*16 array of DIMENSION ( LDA, n ).
30626 * Before entry with UPLO = 'U' or 'u', the leading n by n
30627 * upper triangular part of the array A must contain the upper
30628 * triangular matrix and the strictly lower triangular part of
30629 * A is not referenced.
30630 * Before entry with UPLO = 'L' or 'l', the leading n by n
30631 * lower triangular part of the array A must contain the lower
30632 * triangular matrix and the strictly upper triangular part of
30633 * A is not referenced.
30634 * Note that when DIAG = 'U' or 'u', the diagonal elements of
30635 * A are not referenced either, but are assumed to be unity.
30636 * Unchanged on exit.
30637 *
30638 * LDA - INTEGER.
30639 * On entry, LDA specifies the first dimension of A as declared
30640 * in the calling (sub) program. LDA must be at least
30641 * max( 1, n ).
30642 * Unchanged on exit.
30643 *
30644 * X - COMPLEX*16 array of dimension at least
30645 * ( 1 + ( n - 1 )*abs( INCX ) ).
30646 * Before entry, the incremented array X must contain the n
30647 * element right-hand side vector b. On exit, X is overwritten
30648 * with the solution vector x.
30649 *
30650 * INCX - INTEGER.
30651 * On entry, INCX specifies the increment for the elements of
30652 * X. INCX must not be zero.
30653 * Unchanged on exit.
30654 *
30655 *
30656 * Level 2 Blas routine.
30657 *
30658 * -- Written on 22-October-1986.
30659 * Jack Dongarra, Argonne National Lab.
30660 * Jeremy Du Croz, Nag Central Office.
30661 * Sven Hammarling, Nag Central Office.
30662 * Richard Hanson, Sandia National Labs.
30663 *
30664 *
30665 * .. Parameters ..
30666  COMPLEX*16 ZERO
30667  parameter( zero = ( 0.0d+0, 0.0d+0 ) )
30668 * .. Local Scalars ..
30669  COMPLEX*16 TEMP
30670  INTEGER I, INFO, IX, J, JX, KX
30671  LOGICAL NOCONJ, NOUNIT
30672 * .. External Functions ..
30673  LOGICAL LSAME
30674  EXTERNAL lsame
30675 * .. External Subroutines ..
30676  EXTERNAL xerbla
30677 * .. Intrinsic Functions ..
30678  INTRINSIC dconjg, max
30679 * ..
30680 * .. Executable Statements ..
30681 *
30682 * Test the input parameters.
30683 *
30684  info = 0
30685  IF ( .NOT.lsame( uplo , 'U' ).AND.
30686  $ .NOT.lsame( uplo , 'L' ) )THEN
30687  info = 1
30688  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
30689  $ .NOT.lsame( trans, 'T' ).AND.
30690  $ .NOT.lsame( trans, 'C' ) )THEN
30691  info = 2
30692  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
30693  $ .NOT.lsame( diag , 'N' ) )THEN
30694  info = 3
30695  ELSE IF( n.LT.0 )THEN
30696  info = 4
30697  ELSE IF( lda.LT.max( 1, n ) )THEN
30698  info = 6
30699  ELSE IF( incx.EQ.0 )THEN
30700  info = 8
30701  END IF
30702  IF( info.NE.0 )THEN
30703  CALL xerbla( 'ZTRSV ', info )
30704  RETURN
30705  END IF
30706 *
30707 * Quick return if possible.
30708 *
30709  IF( n.EQ.0 )
30710  $ RETURN
30711 *
30712  noconj = lsame( trans, 'T' )
30713  nounit = lsame( diag , 'N' )
30714 *
30715 * Set up the start point in X if the increment is not unity. This
30716 * will be ( N - 1 )*INCX too small for descending loops.
30717 *
30718  IF( incx.LE.0 )THEN
30719  kx = 1 - ( n - 1 )*incx
30720  ELSE IF( incx.NE.1 )THEN
30721  kx = 1
30722  END IF
30723 *
30724 * Start the operations. In this version the elements of A are
30725 * accessed sequentially with one pass through A.
30726 *
30727  IF( lsame( trans, 'N' ) )THEN
30728 *
30729 * Form x := inv( A )*x.
30730 *
30731  IF( lsame( uplo, 'U' ) )THEN
30732  IF( incx.EQ.1 )THEN
30733  DO 20, j = n, 1, -1
30734  IF( x( j ).NE.zero )THEN
30735  IF( nounit )
30736  $ x( j ) = x( j )/a( j, j )
30737  temp = x( j )
30738  DO 10, i = j - 1, 1, -1
30739  x( i ) = x( i ) - temp*a( i, j )
30740  10 CONTINUE
30741  END IF
30742  20 CONTINUE
30743  ELSE
30744  jx = kx + ( n - 1 )*incx
30745  DO 40, j = n, 1, -1
30746  IF( x( jx ).NE.zero )THEN
30747  IF( nounit )
30748  $ x( jx ) = x( jx )/a( j, j )
30749  temp = x( jx )
30750  ix = jx
30751  DO 30, i = j - 1, 1, -1
30752  ix = ix - incx
30753  x( ix ) = x( ix ) - temp*a( i, j )
30754  30 CONTINUE
30755  END IF
30756  jx = jx - incx
30757  40 CONTINUE
30758  END IF
30759  ELSE
30760  IF( incx.EQ.1 )THEN
30761  DO 60, j = 1, n
30762  IF( x( j ).NE.zero )THEN
30763  IF( nounit )
30764  $ x( j ) = x( j )/a( j, j )
30765  temp = x( j )
30766  DO 50, i = j + 1, n
30767  x( i ) = x( i ) - temp*a( i, j )
30768  50 CONTINUE
30769  END IF
30770  60 CONTINUE
30771  ELSE
30772  jx = kx
30773  DO 80, j = 1, n
30774  IF( x( jx ).NE.zero )THEN
30775  IF( nounit )
30776  $ x( jx ) = x( jx )/a( j, j )
30777  temp = x( jx )
30778  ix = jx
30779  DO 70, i = j + 1, n
30780  ix = ix + incx
30781  x( ix ) = x( ix ) - temp*a( i, j )
30782  70 CONTINUE
30783  END IF
30784  jx = jx + incx
30785  80 CONTINUE
30786  END IF
30787  END IF
30788  ELSE
30789 *
30790 * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x.
30791 *
30792  IF( lsame( uplo, 'U' ) )THEN
30793  IF( incx.EQ.1 )THEN
30794  DO 110, j = 1, n
30795  temp = x( j )
30796  IF( noconj )THEN
30797  DO 90, i = 1, j - 1
30798  temp = temp - a( i, j )*x( i )
30799  90 CONTINUE
30800  IF( nounit )
30801  $ temp = temp/a( j, j )
30802  ELSE
30803  DO 100, i = 1, j - 1
30804  temp = temp - dconjg( a( i, j ) )*x( i )
30805  100 CONTINUE
30806  IF( nounit )
30807  $ temp = temp/dconjg( a( j, j ) )
30808  END IF
30809  x( j ) = temp
30810  110 CONTINUE
30811  ELSE
30812  jx = kx
30813  DO 140, j = 1, n
30814  ix = kx
30815  temp = x( jx )
30816  IF( noconj )THEN
30817  DO 120, i = 1, j - 1
30818  temp = temp - a( i, j )*x( ix )
30819  ix = ix + incx
30820  120 CONTINUE
30821  IF( nounit )
30822  $ temp = temp/a( j, j )
30823  ELSE
30824  DO 130, i = 1, j - 1
30825  temp = temp - dconjg( a( i, j ) )*x( ix )
30826  ix = ix + incx
30827  130 CONTINUE
30828  IF( nounit )
30829  $ temp = temp/dconjg( a( j, j ) )
30830  END IF
30831  x( jx ) = temp
30832  jx = jx + incx
30833  140 CONTINUE
30834  END IF
30835  ELSE
30836  IF( incx.EQ.1 )THEN
30837  DO 170, j = n, 1, -1
30838  temp = x( j )
30839  IF( noconj )THEN
30840  DO 150, i = n, j + 1, -1
30841  temp = temp - a( i, j )*x( i )
30842  150 CONTINUE
30843  IF( nounit )
30844  $ temp = temp/a( j, j )
30845  ELSE
30846  DO 160, i = n, j + 1, -1
30847  temp = temp - dconjg( a( i, j ) )*x( i )
30848  160 CONTINUE
30849  IF( nounit )
30850  $ temp = temp/dconjg( a( j, j ) )
30851  END IF
30852  x( j ) = temp
30853  170 CONTINUE
30854  ELSE
30855  kx = kx + ( n - 1 )*incx
30856  jx = kx
30857  DO 200, j = n, 1, -1
30858  ix = kx
30859  temp = x( jx )
30860  IF( noconj )THEN
30861  DO 180, i = n, j + 1, -1
30862  temp = temp - a( i, j )*x( ix )
30863  ix = ix - incx
30864  180 CONTINUE
30865  IF( nounit )
30866  $ temp = temp/a( j, j )
30867  ELSE
30868  DO 190, i = n, j + 1, -1
30869  temp = temp - dconjg( a( i, j ) )*x( ix )
30870  ix = ix - incx
30871  190 CONTINUE
30872  IF( nounit )
30873  $ temp = temp/dconjg( a( j, j ) )
30874  END IF
30875  x( jx ) = temp
30876  jx = jx - incx
30877  200 CONTINUE
30878  END IF
30879  END IF
30880  END IF
30881 *
30882  RETURN
30883 *
30884 * End of ZTRSV .
30885 *
30886  END
ztrsv
subroutine ztrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:30564
csrot
subroutine csrot(n, cx, incx, cy, incy, c, s)
Definition: blas.f:4300
cdotc
complex function cdotc(n, cx, incx, cy, incy)
Definition: blas.f:69
dtrmm
subroutine dtrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:13893
zsyrk
subroutine zsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:27708
chemm
subroutine chemm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:1785
zhemm
subroutine zhemm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:24531
cdotu
complex function cdotu(n, cx, incx, cy, incy)
Definition: blas.f:107
dsdot
double precision function dsdot(N, SX, INCX, SY, INCY)
Definition: blas.f:10181
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:30151
dtpmv
subroutine dtpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:13291
sspr
subroutine sspr(UPLO, N, ALPHA, X, INCX, AP)
Definition: blas.f:18184
stpsv
subroutine stpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:21029
ctrmv
subroutine ctrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:7145
izamax
integer function izamax(n, zx, incx)
Definition: blas.f:15422
ctbsv
subroutine ctbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:5693
zhpr2
subroutine zhpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
Definition: blas.f:26533
ztpsv
subroutine ztpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:29096
dger
subroutine dger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:9276
cscal
subroutine cscal(n, ca, cx, incx)
Definition: blas.f:4272
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
Definition: blas.f:22716
sgemv
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:16534
real
long real
Definition: gs_test_old.c:28
ctrsm
subroutine ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:7467
ssbmv
subroutine ssbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:17348
dznrm2
double precision function dznrm2(N, X, INCX)
Definition: blas.f:15234
sscal
subroutine sscal(n, sa, sx, incx)
Definition: blas.f:17650
ssyrk
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:19749
drotmg
subroutine drotmg(DD1, DD2, DX1, DY1, DPARAM)
Definition: blas.f:9665
dcabs1
double precision function dcabs1(z)
Definition: blas.f:8295
xerbla
subroutine xerbla(SRNAME, INFO)
Definition: blas.f:22639
chpr
subroutine chpr(UPLO, N, ALPHA, X, INCX, AP)
Definition: blas.f:4035
chemv
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:2089
srotg
subroutine srotg(sa, sb, c, s)
Definition: blas.f:17048
zgbmv
subroutine zgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:22890
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
Definition: blas.f:17011
zhpr
subroutine zhpr(UPLO, N, ALPHA, X, INCX, AP)
Definition: blas.f:26784
cher2k
subroutine cher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:2604
dasum
double precision function dasum(n, dx, incx)
Definition: blas.f:8204
ztrmm
subroutine ztrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:29438
sdot
real function sdot(n, sx, incx, sy, incy)
Definition: blas.f:15793
dspmv
subroutine dspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
Definition: blas.f:10254
scopy
subroutine scopy(n, sx, incx, sy, incy)
Definition: blas.f:15743
cgerc
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:1161
csyrk
subroutine csyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:5024
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
Definition: blas.f:8303
chpr2
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
Definition: blas.f:3784
zgeru
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:24064
dtpsv
subroutine dtpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:13590
cherk
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:3187
zherk
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:25933
dswap
subroutine dswap(n, dx, incx, dy, incy)
Definition: blas.f:10943
cgeru
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:1318
chbmv
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:1476
sgemm
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:16221
sger
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:16794
srotmg
subroutine srotmg(SD1, SD2, SX1, SY1, SPARAM)
Definition: blas.f:17181
dsymm
subroutine dsymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:11000
zsymm
subroutine zsymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:27088
stpmv
subroutine stpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:20730
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
Definition: blas.f:8247
srotm
subroutine srotm(N, SX, INCX, SY, INCY, SPARAM)
Definition: blas.f:17075
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
Definition: blas.f:36
zgerc
subroutine zgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:23907
ztpmv
subroutine ztpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:28758
zdscal
subroutine zdscal(n, da, zx, incx)
Definition: blas.f:22859
zdotc
double complex function zdotc(n, zx, incx, zy, incy)
Definition: blas.f:22749
ssymm
subroutine ssymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:18439
n
i double fun_3term fun_3term int n
Definition: gen_poly_imp.c:66
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
Definition: blas.f:9493
dsyr2
subroutine dsyr2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:11555
zsyr2k
subroutine zsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:27384
scnrm2
real function scnrm2(N, X, INCX)
Definition: blas.f:15676
ztrmv
subroutine ztrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:29829
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
Definition: blas.f:2
ctbmv
subroutine ctbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:5316
crotg
subroutine crotg(ca, cb, c, s)
Definition: blas.f:4252
ctrmm
subroutine ctrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:6754
dsbmv
subroutine dsbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:9835
zher
subroutine zher(UPLO, N, ALPHA, X, INCX, A, LDA)
Definition: blas.f:25721
ssymv
subroutine ssymv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:18733
cher2
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:2354
zdotu
double complex function zdotu(n, zx, incx, zy, incy)
Definition: blas.f:22785
dgemv
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:9016
strsm
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:21973
ctpmv
subroutine ctpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:6074
dscal
subroutine dscal(n, da, dx, incx)
Definition: blas.f:10137
ssyr2k
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:19225
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
Definition: blas.f:22682
dsymv
subroutine dsymv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:11294
dtrsm
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:14534
dtrmv
subroutine dtrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:14247
chpmv
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
Definition: blas.f:3514
i
i
Definition: gen_poly_imp.c:60
csymm
subroutine csymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:4404
dzasum
double precision function dzasum(n, zx, incx)
Definition: blas.f:15200
cgemv
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:881
zher2
subroutine zher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:25100
dnrm2
double precision function dnrm2(N, X, INCX)
Definition: blas.f:9433
dgbmv
subroutine dgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:8403
snrm2
real function snrm2(N, X, INCX)
Definition: blas.f:16951
sswap
subroutine sswap(n, sx, incx, sy, incy)
Definition: blas.f:18382
lsame
logical function lsame(CA, CB)
Definition: blas.f:15463
dspr2
subroutine dspr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
Definition: blas.f:10516
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
Definition: blas.f:15594
zgemv
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:23627
zhbmv
subroutine zhbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:24222
drotg
subroutine drotg(da, db, c, s)
Definition: blas.f:9530
dtbmv
subroutine dtbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:12603
ssyr
subroutine ssyr(UPLO, N, ALPHA, X, INCX, A, LDA)
Definition: blas.f:19551
csscal
subroutine csscal(n, sa, cx, incx)
Definition: blas.f:4338
sdsdot
real function sdsdot(N, SB, SX, INCX, SY, INCY)
Definition: blas.f:15843
zswap
subroutine zswap(n, zx, incx, zy, incy)
Definition: blas.f:27051
zrotg
subroutine zrotg(ca, cb, c, s)
Definition: blas.f:27001
drotm
subroutine drotm(N, DX, INCX, DY, INCY, DPARAM)
Definition: blas.f:9557
zgemm
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:23212
cgbmv
subroutine cgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:145
ctpsv
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
Definition: blas.f:6412
zhemv
subroutine zhemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:24835
stbmv
subroutine stbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:20042
ddot
double precision function ddot(n, dx, incx, dy, incy)
Definition: blas.f:8353
ztbmv
subroutine ztbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:28000
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
Definition: blas.f:12310
sasum
real function sasum(n, sx, incx)
Definition: blas.f:15550
zscal
subroutine zscal(n, za, zx, incx)
Definition: blas.f:27022
dspr
subroutine dspr(UPLO, N, ALPHA, X, INCX, AP)
Definition: blas.f:10745
ctrsv
subroutine ctrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:7880
zher2k
subroutine zher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:25350
idamax
integer function idamax(n, dx, incx)
Definition: blas.f:15344
cswap
subroutine cswap(n, cx, incx, cy, incy)
Definition: blas.f:4367
zdrot
subroutine zdrot(n, zx, incx, zy, incy, c, s)
Definition: blas.f:22821
cher
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
Definition: blas.f:2974
dtrsv
subroutine dtrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:14911
ssyr2
subroutine ssyr2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: blas.f:18994
dtbsv
subroutine dtbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:12945
zhpmv
subroutine zhpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
Definition: blas.f:26263
strmm
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: blas.f:21332
icamax
integer function icamax(n, cx, incx)
Definition: blas.f:15301
sgbmv
subroutine sgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: blas.f:15921
dsyr
subroutine dsyr(UPLO, N, ALPHA, X, INCX, A, LDA)
Definition: blas.f:12112
scasum
real function scasum(n, cx, incx)
Definition: blas.f:15642
dgemm
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:8703
strsv
subroutine strsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:22350
sspr2
subroutine sspr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
Definition: blas.f:17955
strmv
subroutine strmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: blas.f:21686
dsyr2k
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:11786
ztbsv
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:28377
isamax
integer function isamax(n, sx, incx)
Definition: blas.f:15383
sspmv
subroutine sspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
Definition: blas.f:17693
cgemm
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:467
csyr2k
subroutine csyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: blas.f:4700
stbsv
subroutine stbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
Definition: blas.f:20384